packages feed

ghc-lib-parser 9.6.7.20250325 → 9.8.1.20231009

raw patch · 281 files changed

+38626/−31441 lines, 281 filesdep −ghc-internaldep ~basedep ~bytestringdep ~ghc-prim

Dependencies removed: ghc-internal

Dependency ranges changed: base, bytestring, ghc-prim

Files

compiler/CodeGen.Platform.h view
@@ -452,34 +452,34 @@ 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 +555,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 +740,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)
compiler/GHC/Builtin/Names.hs view
@@ -4,22 +4,23 @@ \section[GHC.Builtin.Names]{Definitions of prelude modules and names}  -Nota Bene: all Names defined in here should come from the base package+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.    pREL_BASE_Name :: ModuleName+        e.g.    pRELUDE_NAME :: ModuleName   - Modules for prelude modules-        e.g.    pREL_Base :: Module+        e.g.    pRELUDE :: Module   - Uniques for Ids, DataCons, TyCons and Classes that the compiler    "knows about" in some way-        e.g.    intTyConKey :: Unique+        e.g.    orderingTyConKey :: Unique                 minusClassOpKey :: Unique   - Names for Ids, DataCons, TyCons and Classes that the compiler    "knows about" in some way-        e.g.    intTyConName :: Name+        e.g.    orderingTyConName :: Name                 minusName    :: Name    One of these Names contains         (a) the module and occurrence name of the thing@@ -31,8 +32,9 @@    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+   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]@@ -501,6 +503,10 @@         , typeErrorVAppendDataConName         , typeErrorShowTypeDataConName +        -- "Unsatisfiable" constraint+        , unsatisfiableClassName+        , unsatisfiableIdName+         -- Unsafe coercion proofs         , unsafeEqualityProofName         , unsafeEqualityTyConName@@ -653,9 +659,9 @@ 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))+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")@@ -866,10 +872,10 @@ 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")+unPar1_RDR  = fieldQual_RDR gHC_GENERICS (fsLit "Par1")  (fsLit "unPar1")+unRec1_RDR  = fieldQual_RDR gHC_GENERICS (fsLit "Rec1")  (fsLit "unRec1")+unK1_RDR    = fieldQual_RDR gHC_GENERICS (fsLit "K1")    (fsLit "unK1")+unComp1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Comp1") (fsLit "unComp1")  from_RDR  = varQual_RDR gHC_GENERICS (fsLit "from") from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")@@ -898,12 +904,12 @@ 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#")+uAddrHash_RDR   = fieldQual_RDR gHC_GENERICS (fsLit "UAddr")   (fsLit "uAddr#")+uCharHash_RDR   = fieldQual_RDR gHC_GENERICS (fsLit "UChar")   (fsLit "uChar#")+uDoubleHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UDouble") (fsLit "uDouble#")+uFloatHash_RDR  = fieldQual_RDR gHC_GENERICS (fsLit "UFloat")  (fsLit "uFloat#")+uIntHash_RDR    = fieldQual_RDR gHC_GENERICS (fsLit "UInt")    (fsLit "uInt#")+uWordHash_RDR   = fieldQual_RDR gHC_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,@@ -929,6 +935,9 @@ 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)+ {- ************************************************************************ *                                                                      *@@ -1447,6 +1456,13 @@ typeErrorShowTypeDataConName =   dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey +-- "Unsatisfiable" constraint+unsatisfiableClassName, unsatisfiableIdName :: Name+unsatisfiableClassName =+  clsQual gHC_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey+unsatisfiableIdName =+  varQual gHC_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey+ -- Unsafe coercion proofs unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,   unsafeReflDataConName :: Name@@ -1988,9 +2004,13 @@ uIntTyConKey    = mkPreludeTyConUnique 162 uWordTyConKey   = mkPreludeTyConUnique 163 +-- "Unsatisfiable" constraint+unsatisfiableClassNameKey :: Unique+unsatisfiableClassNameKey = mkPreludeTyConUnique 170+ -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique-errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 181+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181  coercibleTyConKey :: Unique coercibleTyConKey = mkPreludeTyConUnique 183@@ -2498,19 +2518,6 @@ 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@@ -2523,9 +2530,6 @@ toDynIdKey            = mkPreludeMiscIdUnique 530  -bitIntegerIdKey :: Unique-bitIntegerIdKey       = mkPreludeMiscIdUnique 550- heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique eqSCSelIdKey        = mkPreludeMiscIdUnique 551 heqSCSelIdKey       = mkPreludeMiscIdUnique 552@@ -2559,6 +2563,10 @@ getFieldClassOpKey = mkPreludeMiscIdUnique 572 setFieldClassOpKey = mkPreludeMiscIdUnique 573 +-- "Unsatisfiable" constraints+unsatisfiableIdNameKey :: Unique+unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580+ ------------------------------------------------------ -- ghc-bignum uses 600-699 uniques ------------------------------------------------------@@ -2810,6 +2818,7 @@ pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n   = isBuiltInSyntax n+  || isTupleTyConName n   || any (n `hasKey`)     [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey     , liftedDataConKey, unliftedDataConKey
compiler/GHC/Builtin/PrimOps.hs view
@@ -551,36 +551,43 @@ 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
compiler/GHC/Builtin/Types.hs view
@@ -18,7 +18,7 @@         mkWiredInIdName,    -- used in GHC.Types.Id.Make          -- * All wired in things-        wiredInTyCons, isBuiltInOcc_maybe, isPunOcc_maybe,+        wiredInTyCons, isBuiltInOcc_maybe, isTupleTyOcc_maybe, isPunOcc_maybe,          -- * Bool         boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,@@ -209,7 +209,11 @@  import Data.Foldable import Data.List        ( elemIndex, intersperse )+import Numeric          ( showInt ) +import Text.Read (readMaybe)+import Data.Char (ord, isDigit)+ alpha_tyvar :: [TyVar] alpha_tyvar = [alphaTyVar] @@ -734,16 +738,16 @@  However the /naming/ of the type/data constructors for one-tuples is a bit odd:-  3-tuples:  (,,)   (,,)#-  2-tuples:  (,)    (,)#+  3-tuples:  Tuple3   (,,)#+  2-tuples:  Tuple2   (,)#   1-tuples:  ??-  0-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 ()     = ()+  data Unit = ()   data Solo a = MkSolo a-  data (a,b)  = (a,b)+  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:@@ -852,13 +856,54 @@     choose_ns tc dc       | isTcClsNameSpace ns   = tc       | isDataConNameSpace ns = dc-      | otherwise             = pprPanic "tup_name" (ppr occ)+      | otherwise             = pprPanic "tup_name" (ppr occ <+> parens (pprNameSpace ns))       where ns = occNameSpace occ      tup_name boxity arity       = choose_ns (getName (tupleTyCon   boxity arity))                   (getName (tupleDataCon boxity arity)) +isTupleTyOcc_maybe :: Module -> OccName -> Maybe Name+isTupleTyOcc_maybe mod occ+  | mod == gHC_TUPLE_PRIM+  = match_occ+  where+    match_occ+      | occ == occName unitTyConName = Just unitTyConName+      | occ == occName soloTyConName = Just soloTyConName+      | otherwise = isTupleNTyOcc_maybe occ+isTupleTyOcc_maybe _ _ = Nothing+++-- | This is only for Tuple<n>, not for Unit or Solo+isTupleNTyOcc_maybe :: OccName -> Maybe Name+isTupleNTyOcc_maybe occ =+  case occNameString occ of+    'T':'u':'p':'l':'e':str | Just n <- readInt str, n > 1+      -> Just (tupleTyConName BoxedTuple n)+    _ -> Nothing++-- | See Note [Small Ints parsing]+readInt :: String -> Maybe Int+readInt s = case s of+  [c] | isDigit c -> Just (digit_to_int c)+  [c1, c2] | isDigit c1, isDigit c2+    -> Just (digit_to_int c1 * 10 + digit_to_int c2)+  _ -> readMaybe s+  where+    digit_to_int :: Char -> Int+    digit_to_int c = ord c - ord '0'++{-+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.+-}+ -- 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.@@ -872,6 +917,10 @@ isPunOcc_maybe mod occ   | mod == gHC_TYPES, occ == occName listTyConName   = Just listTyConName+  | mod == gHC_TUPLE_PRIM, occ == occName unitTyConName+  = Just unitTyConName+  | mod == gHC_TUPLE_PRIM+  = isTupleNTyOcc_maybe occ isPunOcc_maybe _ _ = Nothing  mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName@@ -887,10 +936,15 @@ 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 ++ ")"+mkBoxedTupleStr ns 0+  | isDataConNameSpace ns = "()"+  | otherwise             = "Unit"+mkBoxedTupleStr ns 1+  | isDataConNameSpace ns = "MkSolo"  -- See Note [One-tuples]+  | otherwise             = "Solo"+mkBoxedTupleStr ns ar+  | isDataConNameSpace ns = '(' : commas ar ++ ")"+  | otherwise             = "Tuple" ++ showInt ar ""  mkUnboxedTupleStr :: Arity -> String mkUnboxedTupleStr 0  = "(##)"@@ -903,7 +957,7 @@ mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"  commas :: Arity -> String-commas ar = take (ar-1) (repeat ',')+commas ar = replicate (ar-1) ','  cTupleTyCon :: Arity -> TyCon cTupleTyCon i@@ -1052,7 +1106,7 @@     boxity  = Boxed     modu    = gHC_TUPLE_PRIM     tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq-                         (ATyCon tycon) BuiltInSyntax+                         (ATyCon tycon) UserSyntax     dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq                             (AConLike (RealDataCon tuple_con)) BuiltInSyntax     tc_uniq = mkTupleTyConUnique   boxity arity@@ -1126,6 +1180,9 @@ unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 +unitTyConName :: Name+unitTyConName = tyConName unitTyCon+ unitTyConKey :: Unique unitTyConKey = getUnique unitTyCon @@ -1138,6 +1195,9 @@ soloTyCon :: TyCon soloTyCon = tupleTyCon Boxed 1 +soloTyConName :: Name+soloTyConName = tyConName soloTyCon+ pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2 @@ -1576,10 +1636,11 @@   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)+      = 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) @@ -1939,7 +2000,7 @@     --        recall: data Int = I# Int#     --     --      BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty-    --             , bi_boxed_type = Int8Box ty }A+    --             , bi_boxed_type = Int8Box ty }     --        recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a  boxingDataCon :: Type -> BoxingInfo b
compiler/GHC/Builtin/Types/Prim.hs view
@@ -759,7 +759,7 @@  (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].+     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)@@ -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.
compiler/GHC/Builtin/Uniques.hs view
@@ -19,6 +19,7 @@       -- *** Vanilla     , mkTupleTyConUnique     , mkTupleDataConUnique+    , isTupleTyConUnique       -- *** Constraint     , mkCTupleTyConUnique     , mkCTupleDataConUnique@@ -30,10 +31,12 @@     , mkPreludeMiscIdUnique, mkPreludeDataConUnique     , mkPreludeTyConUnique, mkPreludeClassUnique -    , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique     , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique     , mkCostCentreUnique +    , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique+    , mkFldNSUnique, isFldNSUnique+     , mkBuiltinUnique     , mkPseudoUniqueE @@ -63,10 +66,8 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain (assert)  import Data.Maybe-import GHC.Utils.Word64 (word64ToInt)  -- | Get the 'Name' associated with a known-key 'Unique'. knownUniqueName :: Unique -> Maybe Name@@ -82,9 +83,7 @@       'm' -> Just $ getCTupleDataConName n       _   -> Nothing   where-    (tag, n') = unpkUnique u-    -- Known unique names are guaranteed to fit in Int, so we don't need the whole Word64.-    n = assert (isValidKnownKeyUnique u) (word64ToInt n')+    (tag, n) = unpkUnique u  {- Note [Unique layout for unboxed sums]@@ -116,14 +115,14 @@     assertPpr (arity <= 0x3f) (ppr arity) $               -- 0x3f since we only have 6 bits to encode the               -- alternative-    mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc)+    mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)  mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkSumDataConUnique alt arity   | alt >= arity   = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity)   | otherwise-  = mkUniqueInt 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}+  = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}  getUnboxedSumName :: Int -> Name getUnboxedSumName n@@ -210,17 +209,17 @@ -}  mkCTupleTyConUnique :: Arity -> Unique-mkCTupleTyConUnique a = mkUniqueInt 'k' (2*a)+mkCTupleTyConUnique a = mkUnique 'k' (2*a)  mkCTupleDataConUnique :: Arity -> Unique-mkCTupleDataConUnique a = mkUniqueInt 'm' (3*a)+mkCTupleDataConUnique a = mkUnique 'm' (3*a)  mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique mkCTupleSelIdUnique sc_pos arity   | sc_pos >= arity   = panic ("mkCTupleSelIdUnique: " ++ show sc_pos ++ " >= " ++ show arity)   | otherwise-  = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)+  = mkUnique 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)  getCTupleTyConName :: Int -> Name getCTupleTyConName n =@@ -263,13 +262,24 @@ -- Normal tuples  mkTupleDataConUnique :: Boxity -> Arity -> Unique-mkTupleDataConUnique Boxed          a = mkUniqueInt '7' (3*a)    -- may be used in C labels-mkTupleDataConUnique Unboxed        a = mkUniqueInt '8' (3*a)+mkTupleDataConUnique Boxed          a = mkUnique '7' (3*a)    -- may be used in C labels+mkTupleDataConUnique Unboxed        a = mkUnique '8' (3*a)  mkTupleTyConUnique :: Boxity -> Arity -> Unique-mkTupleTyConUnique Boxed           a  = mkUniqueInt '4' (2*a)-mkTupleTyConUnique Unboxed         a  = mkUniqueInt '5' (2*a)+mkTupleTyConUnique Boxed           a  = mkUnique '4' (2*a)+mkTupleTyConUnique Unboxed         a  = mkUnique '5' (2*a) +-- | This function is an 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+ getTupleTyConName :: Boxity -> Int -> Name getTupleTyConName boxity n =     case n `divMod` 2 of@@ -288,7 +298,7 @@       _          -> panic "getTupleDataConName: impossible"  {--Note [Uniques for wired-in prelude things and known tags]+Note [Uniques for wired-in prelude things and known masks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Allocation of unique supply characters:         v,u: for renumbering value-, and usage- vars.@@ -348,36 +358,41 @@ mkPrimOpWrapperUnique  :: Int -> Unique mkPreludeMiscIdUnique  :: Int -> Unique -mkAlphaTyVarUnique   i = mkUniqueInt '1' i-mkPreludeClassUnique i = mkUniqueInt '2' i+mkAlphaTyVarUnique   i = mkUnique '1' i+mkPreludeClassUnique i = mkUnique '2' i  ---------------------------------------------------mkPrimOpIdUnique op         = mkUniqueInt '9' (2*op)-mkPrimOpWrapperUnique op    = mkUniqueInt '9' (2*op+1)-mkPreludeMiscIdUnique  i    = mkUniqueInt '0' i+mkPrimOpIdUnique op         = mkUnique '9' (2*op)+mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)+mkPreludeMiscIdUnique  i    = mkUnique '0' i  mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique -mkBuiltinUnique i = mkUniqueInt 'B' i-mkPseudoUniqueE i = mkUniqueInt 'E' i -- used in NCG spiller to create spill VirtualRegs+mkBuiltinUnique i = mkUnique 'B' i+mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs  mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique-mkRegSingleUnique = mkUniqueInt 'R'-mkRegSubUnique    = mkUniqueInt 'S'-mkRegPairUnique   = mkUniqueInt 'P'-mkRegClassUnique  = mkUniqueInt 'L'+mkRegSingleUnique = mkUnique 'R'+mkRegSubUnique    = mkUnique 'S'+mkRegPairUnique   = mkUnique 'P'+mkRegClassUnique  = mkUnique 'L'  mkCostCentreUnique :: Int -> Unique-mkCostCentreUnique = mkUniqueInt 'C'+mkCostCentreUnique = mkUnique '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 = mkUnique 'f' (uniqueOfFS fs) +isFldNSUnique :: Unique -> Bool+isFldNSUnique uniq = case unpkUnique uniq of+  (tag, _) -> tag == 'f'+ initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 @@ -386,7 +401,7 @@ -- See Note [Related uniques for wired-in things]  mkPreludeTyConUnique   :: Int -> Unique-mkPreludeTyConUnique i = mkUniqueInt '3' (2*i)+mkPreludeTyConUnique i = mkUnique '3' (2*i)  tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique  u = incrUnique u@@ -396,7 +411,7 @@ -- See Note [Related uniques for wired-in things]  mkPreludeDataConUnique :: Int -> Unique-mkPreludeDataConUnique i = mkUniqueInt '6' (3*i)    -- Must be alphabetic+mkPreludeDataConUnique i = mkUnique '6' (3*i)    -- Must be alphabetic  dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique  u = incrUnique u@@ -422,7 +437,7 @@ -- A little delicate!  mkBoxingTyConUnique :: Int -> Unique-mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i)+mkBoxingTyConUnique i = mkUnique 'b' (5*i)  boxingDataConUnique :: Unique -> Unique boxingDataConUnique u = stepUnique u 2
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/ByteCode/Types.hs view
@@ -11,7 +11,7 @@   , FFIInfo(..)   , RegBitmap(..)   , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo-  , ByteOff(..), WordOff(..)+  , ByteOff(..), WordOff(..), HalfWord(..)   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)   , AddrEnv, AddrPtr(..)@@ -44,7 +44,6 @@ import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) import GHC.Iface.Syntax-import Language.Haskell.Syntax.Module.Name (ModuleName)  -- ----------------------------------------------------------------------------- -- Compiled Byte Code@@ -80,6 +79,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) @@ -189,7 +194,7 @@ data CgBreakInfo    = CgBreakInfo    { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint-   , cgb_vars   :: ![Maybe (IfaceIdBndr, Word16)]+   , cgb_vars   :: ![Maybe (IfaceIdBndr, Word)]    , cgb_resty  :: !IfaceType    } -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval@@ -237,7 +242,6 @@         -- ^ 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 -> ()@@ -247,8 +251,7 @@   rnf modBreaks_vars `seq`   rnf modBreaks_decls `seq`   rnf modBreaks_ccs `seq`-  rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`-  rnf modBreaks_module+  rnf (fmap seqCgBreakInfo modBreaks_breakInfo)  -- | Construct an empty ModBreaks emptyModBreaks :: ModBreaks@@ -260,7 +263,6 @@    , modBreaks_decls = array (0,-1) []    , modBreaks_ccs = array (0,-1) []    , modBreaks_breakInfo = IntMap.empty-   , modBreaks_module = toRemotePtr nullPtr    }  {-
compiler/GHC/Cmm.hs view
@@ -229,15 +229,16 @@         -- place to convey this information from the code generator to         -- where we build the static closures in         -- GHC.Cmm.Info.Build.doSRTs.-    } deriving (Eq, Ord)+    } deriving Eq  instance OutputableP Platform CmmInfoTable where     pdoc = pprInfoTable + data ProfilingInfo   = NoProfilingInfo   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc-  deriving (Eq, Ord)+  deriving Eq ----------------------------------------------------------------------------- --              Static Data -----------------------------------------------------------------------------
compiler/GHC/Cmm/CLabel.hs view
@@ -839,7 +839,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)
compiler/GHC/Cmm/Dataflow/Collections.hs view
@@ -12,11 +12,10 @@  import GHC.Prelude -import qualified GHC.Data.Word64Map.Strict as M-import qualified GHC.Data.Word64Set as S+import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as S  import Data.List (foldl1')-import Data.Word (Word64)  class IsSet set where   type ElemOf set@@ -108,10 +107,10 @@ -- Basic instances ----------------------------------------------------------------------------- -newtype UniqueSet = US S.Word64Set deriving (Eq, Ord, Show, Semigroup, Monoid)+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)  instance IsSet UniqueSet where-  type ElemOf UniqueSet = Word64+  type ElemOf UniqueSet = Int    setNull (US s) = S.null s   setSize (US s) = S.size s@@ -134,11 +133,11 @@   setElems (US s) = S.elems s   setFromList ks = US (S.fromList ks) -newtype UniqueMap v = UM (M.Word64Map v)+newtype UniqueMap v = UM (M.IntMap v)   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  instance IsMap UniqueMap where-  type KeyOf UniqueMap = Word64+  type KeyOf UniqueMap = Int    mapNull (UM m) = M.null m   mapSize (UM m) = M.size m
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -20,26 +20,25 @@ -- TODO: This should really just use GHC's Unique and Uniq{Set,FM} import GHC.Cmm.Dataflow.Collections -import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)+import GHC.Types.Unique (Uniquable(..)) import GHC.Data.TrieMap-import Data.Word (Word64)   ----------------------------------------------------------------------------- --              Label ----------------------------------------------------------------------------- -newtype Label = Label { lblToUnique :: Word64 }+newtype Label = Label { lblToUnique :: Int }   deriving (Eq, Ord) -mkHooplLabel :: Word64 -> Label+mkHooplLabel :: Int -> Label mkHooplLabel = Label  instance Show Label where   show (Label n) = "L" ++ show n  instance Uniquable Label where-  getUnique label = mkUniqueGrimily (lblToUnique label)+  getUnique label = getUnique (lblToUnique label)  instance Outputable Label where   ppr label = ppr (getUnique label)
compiler/GHC/Cmm/Expr.hs view
@@ -12,11 +12,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 +248,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 +385,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 +435,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
compiler/GHC/Cmm/MachOp.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Cmm.MachOp@@ -26,6 +28,9 @@     -- Atomic read-modify-write     , MemoryOrdering(..)     , AtomicMachOp(..)++    -- Fused multiply-add+    , FMASign(..), pprFMASign    ) where @@ -108,6 +113,10 @@   | MO_F_Mul  Width   | MO_F_Quot Width +  -- Floating-point fused multiply-add operations+  -- | Fused multiply-add, see 'FMASign'.+  | MO_FMA FMASign Width+   -- Floating point comparison   | MO_F_Eq Width   | MO_F_Ne Width@@ -180,7 +189,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@@ -418,6 +450,9 @@     MO_F_Mul r          -> cmmFloat r     MO_F_Quot r         -> cmmFloat r     MO_F_Neg r          -> cmmFloat r++    MO_FMA _ r          -> cmmFloat r+     MO_F_Eq  {}         -> comparisonResultRep platform     MO_F_Ne  {}         -> comparisonResultRep platform     MO_F_Ge  {}         -> comparisonResultRep platform@@ -509,6 +544,9 @@     MO_F_Mul r          -> [r,r]     MO_F_Quot r         -> [r,r]     MO_F_Neg r          -> [r]++    MO_FMA _ r          -> [r,r,r]+     MO_F_Eq  r          -> [r,r]     MO_F_Ne  r          -> [r,r]     MO_F_Ge  r          -> [r,r]
compiler/GHC/Cmm/Node.hs view
@@ -565,7 +565,6 @@     where fold :: forall a b.  UserOfRegs GlobalReg a                => (b -> GlobalReg -> 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
compiler/GHC/Cmm/Reg.hs view
@@ -11,12 +11,11 @@     , 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     ) where  import GHC.Prelude@@ -30,10 +29,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+    { globalRegUseGlobalReg :: !GlobalReg+      -- ^ The underlying 'GlobalReg'+    , globalRegUseType      :: !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 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 +96,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) = globalRegUseType reg +cmmRegWidth :: CmmReg -> Width+cmmRegWidth = typeWidth . cmmRegType  ----------------------------------------------------------------------------- --              Local registers@@ -129,13 +183,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@@ -192,104 +248,9 @@   -- 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 +261,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 +289,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
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, cmmEqType_ignoring_ptrhood     , isFloatType, isGcPtrType, isBitsType     , isWordAny, isWord32, isWord64     , isFloat64, isFloat32@@ -105,6 +106,9 @@ --- 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/Core.hs view
@@ -292,7 +292,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) $@@ -368,37 +368,36 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 contructor 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -496,6 +495,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,11 +622,7 @@       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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -657,12 +691,6 @@ 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@@ -1107,7 +1135,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@@ -2101,7 +2129,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/Class.hs view
@@ -17,8 +17,8 @@         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, isAbstractClass,     ) where  import GHC.Prelude@@ -294,6 +294,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
@@ -39,8 +39,8 @@         mkSymCo, mkTransCo,         mkSelCo, getNthFun, getNthFromType, mkLRCo,         mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,-        mkFunCo1, mkFunCo2, mkFunCoNoFTF, mkFunResCo,-        mkNakedFunCo1, mkNakedFunCo2,+        mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,+        mkNakedFunCo,         mkForAllCo, mkForAllCos, mkHomoForAllCos,         mkPhantomCo,         mkHoleCo, mkUnivCo, mkSubCo,@@ -51,7 +51,7 @@         castCoercionKind, castCoercionKind1, castCoercionKind2,          mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,+        mkNomPrimEqPred,          -- ** Decomposition         instNewTyCon_maybe,@@ -811,29 +811,20 @@ -- 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+mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo 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+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 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag-                              -> CoercionN -> Coercion -> Coercion -> Coercion+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-  = 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+  -- See Note [No assertion check on mkFunCo]   | Just (ty1, _) <- isReflCo_maybe arg_co   , Just (ty2, _) <- isReflCo_maybe res_co   , Just (w, _)   <- isReflCo_maybe w@@ -844,6 +835,19 @@           , 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@@ -875,6 +879,7 @@     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.@@ -2081,7 +2086,7 @@                               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 (FunTy af w t1 t2) = mkFunCo 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@@ -2610,7 +2615,8 @@   in   TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] --- | Creates a primitive type equality predicate.+-- | Creates a primitive nominal type equality predicate.+--      t1 ~# t2 -- Invariant: the types are not Coercions mkPrimEqPred :: Type -> Type -> Type mkPrimEqPred ty1 ty2@@ -2619,22 +2625,9 @@     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]-+-- | Creates a primitive representational type equality predicate.+--      t1 ~R# t2+-- Invariant: the types are not Coercions mkReprPrimEqPred :: Type -> Type -> Type mkReprPrimEqPred ty1  ty2   = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]@@ -2642,6 +2635,17 @@     k1 = typeKind ty1     k2 = typeKind ty2 +-- | Makes a lifted equality predicate at the given role+mkPrimEqPredRole :: Role -> Type -> Type -> PredType+mkPrimEqPredRole Nominal          = mkPrimEqPred+mkPrimEqPredRole Representational = mkReprPrimEqPred+mkPrimEqPredRole Phantom          = panic "mkPrimEqPredRole phantom"++-- | Creates a primitive nominal type equality predicate with an explicit+--   (but homogeneous) kind: (~#) k k ty1 ty2+mkNomPrimEqPred :: Kind -> Type -> Type -> Type+mkNomPrimEqPred k ty1 ty2 = mkTyConApp eqPrimTyCon [k, k, ty1, ty2]+ -- | Assuming that two types are the same, ignoring coercions, find -- a nominal coercion between the types. This is useful when optimizing -- transitivity over coercion applications, where splitting two@@ -2672,7 +2676,7 @@     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)+        mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2)      go (TyConApp tc1 args1) (TyConApp tc2 args2)       = assert (tc1 == tc2) $@@ -2753,15 +2757,17 @@     folder = TyCoFolder { tcf_view  = noView                         , tcf_tyvar = const2 (Monoid.Any False)                         , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = const2 (Monoid.Any True)+                        , tcf_hole  = \_ hole -> Monoid.Any (isHeteroKindCoHole hole)                         , tcf_tycobinder = const2                         } --- | Is there a coercion hole in this type?+-- | Is there a hetero-kind coercion hole in this type?+--   (That is, a coercion hole with ch_hetero_kind=True.)+-- See wrinkle (EIK2) of Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality hasCoercionHoleTy :: Type -> Bool hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty --- | Is there a coercion hole in this coercion?+-- | Is there a hetero-kind coercion hole in this coercion? hasCoercionHoleCo :: Coercion -> Bool hasCoercionHoleCo = Monoid.getAny . has_co_hole_co
compiler/GHC/Core/Coercion.hs-boot view
@@ -17,9 +17,9 @@ 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+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@@ -36,6 +36,8 @@ mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +funRole :: Role -> FunSel -> Role+ isGReflCo :: Coercion -> Bool isReflCo :: Coercion -> Bool isReflexiveCo :: Coercion -> Bool@@ -45,8 +47,6 @@  mkCoercionType :: Role -> Type -> Type -> Type -data LiftingContext-liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion seqCo :: Coercion -> ()  coercionKind :: Coercion -> Pair Type
compiler/GHC/Core/Coercion/Opt.hs view
@@ -4,7 +4,6 @@  module GHC.Core.Coercion.Opt    ( optCoercion-   , checkAxInstCo    , OptCoercionOpts (..)    ) where@@ -804,37 +803,38 @@ -- Push transitivity inside axioms opt_trans_rule is co1 co2 -  -- See Note [Why call checkAxInstCo during optimisation]+  -- See Note [Push transitivity inside axioms] and+  -- Note [Push transitivity inside newtype axioms only]   -- TrPushSymAxR   | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe+  , isNewTyCon (coAxiomTyCon con)   , 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+  , isNewTyCon (coAxiomTyCon con)   , 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+  , isNewTyCon (coAxiomTyCon con)   , 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+  , isNewTyCon (coAxiomTyCon con)   , 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@@ -915,30 +915,87 @@   = Just res  {--Note [Conflict checking with AxiomInstCo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following type family and axiom:+Note [Push transitivity inside axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+opt_trans_rule tries to push transitivity inside axioms to deal with cases like+the following: -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 }+    newtype N a = MkN a -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".+    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 @@ -1028,39 +1085,6 @@ 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
compiler/GHC/Core/ConLike.hs view
@@ -9,9 +9,11 @@  module GHC.Core.ConLike (           ConLike(..)+        , conLikeConLikeName         , isVanillaConLike         , conLikeArity         , conLikeFieldLabels+        , conLikeConInfo         , conLikeInstOrigArgTys         , conLikeUserTyVarBinders         , conLikeExTyCoVars@@ -29,16 +31,19 @@ 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.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 +66,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)+ {- ************************************************************************ *                                                                      *@@ -112,6 +121,11 @@ 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 (conLikeArity con) (conLikeFieldLabels con)  -- | Returns just the instantiated /value/ argument types of a 'ConLike', -- (excluding dictionary args)
compiler/GHC/Core/DataCon.hs view
@@ -22,7 +22,7 @@         eqSpecPair, eqSpecPreds,          -- ** Field labels-        FieldLabel(..), FieldLabelString,+        FieldLabel(..), flLabel, FieldLabelString,          -- ** Type construction         mkDataCon, fIRST_TAG,@@ -141,9 +141,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 +221,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@@ -528,7 +541,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@@ -586,12 +599,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,7 +624,16 @@     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:@@ -625,7 +657,7 @@     (that is, they are TyVars/TyCoVars instead of ForAllTyBinders).  Often (dcUnivTyVars ++ dcExTyCoVars) = dcUserTyVarBinders; but they may differ-for three reasons, coming next:+for two reasons, coming next:  --- Reason (R1): Order of quantification in GADT syntax --- @@ -714,55 +746,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@@ -859,7 +842,7 @@ -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ data HsSrcBang =-  HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.SourceText+  HsSrcBang SourceText -- Note [Pragma source text] in "GHC.Types.SourceText"             SrcUnpackedness             SrcStrictness   deriving Data.Data@@ -1018,52 +1001,7 @@ 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}@@ -1279,11 +1217,9 @@       -- 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@@ -1737,13 +1673,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@@ -1917,20 +1865,15 @@                               , 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
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,6 +38,7 @@  import GHC.Prelude +import GHC.Core( IsOrphan, chooseOrphanAnchor ) import GHC.Core.Unify import GHC.Core.Type as Type import GHC.Core.TyCo.Rep@@ -126,6 +127,8 @@             -- in GHC.Core.Coercion.Axiom              , fi_rhs :: Type         --   the RHS, with its freshened vars++            , fi_orphan :: IsOrphan             }  data FamFlavor@@ -254,6 +257,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 +310,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 +321,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
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,+        Canonical, PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,-        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,+        instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,         instanceDFunId, updateClsInstDFuns, updateClsInstDFun,         fuzzyClsInstCmp, orphNamesOfClsInst,          InstEnvs(..), VisibleOrphanModules, InstEnv,+        LookupInstanceErrReason (..),         mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,         filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,         anyInstEnv,@@ -40,6 +41,7 @@ import GHC.Core.RoughMap import GHC.Core.Class import GHC.Core.Unify+import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )  import GHC.Unit.Module.Env import GHC.Unit.Types@@ -50,12 +52,13 @@ 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@@ -119,10 +122,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]@@ -255,13 +259,13 @@ -- Decomposes the DFunId instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) -mkLocalInstance :: DFunId -> OverlapFlag-                -> [TyVar] -> Class -> [Type]-                -> ClsInst+mkLocalClsInst :: DFunId -> OverlapFlag+               -> [TyVar] -> Class -> [Type]+               -> 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   = ClsInst { is_flag = oflag, is_dfun = dfun             , is_tvs = tvs             , is_dfun_name = dfun_name@@ -298,18 +302,18 @@      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?+                  -> 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   = ClsInst { is_flag = oflag, is_dfun = dfun             , is_tvs = tvs, is_tys = tys             , is_dfun_name = dfun_name@@ -576,50 +580,54 @@ instance declaration itself, controlled as follows:   * An instance is "incoherent"-   if it has an INCOHERENT pragma, or-   if it appears in a module compiled with -XIncoherentInstances.+   if it has an `INCOHERENT` pragma, or+   if it appears in a module compiled with `-XIncoherentInstances`.   * An instance is "overlappable"-   if it has an OVERLAPPABLE or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or+   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+   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. See Note [Instance and Given overlap] in+      GHC.Tc.Solver.Dict. -*  Eliminate any candidate `IX` for which both of the following hold:+(IL1) 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/. -   -  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. -   -  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).+(IL4) If all the remaining candidates are *incoherent*, the search succeeds,+      returning an arbitrary surviving candidate. --  If the selected candidate (from the previous step) is incoherent, the-   search succeeds, returning that candidate.+(IL5) If more than one non-*incoherent* candidate remains, the search+      fails.  Otherwise there is exactly one non-*incoherent*+      candidate; call it the "prime candidate". --  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.+(IL6) Now 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* top-level instances, the search succeeds,+      returning the prime candidate. Otherwise the search fails.  Notice that these rules are not influenced by flag settings in the client module, where the instances are *used*. These rules make it@@ -747,6 +755,140 @@ 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.  How do we guarantee this?  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], which 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 use its `OverlapFlag` to+  label it as either+  * `Incoherent`: meaning incoherent but still specialisable, or+  * `NonCanonical`: meaning incoherent and not specialisable.++The module-wide `-fspecialise-incoherents` flag determines which+choice is made.  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" the dictionary constructed by a+  (potentially) incoherent use of an instance declaration whose+  `OverlapFlag` is `NonCanonical`.++* 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 (IL6) of the instance lookup.++* That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence+  transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary.++* `GHC.HsToCore.Binds.dsHsWrapper` desugars the evidence application (f d) into+  (nospec f d) if `d` is incoherent. It has to do a dependency analysis to+  determine transitive dependencies, but we need to do that anyway.+  See Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds.++  See also Note [nospecId magic] in GHC.Types.Id.Make. -}  type DFunInstType = Maybe Type@@ -826,44 +968,75 @@ -- 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]+-- | 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)++type Canonical = Bool++-- See Note [Recording coherence information in `PotentialUnifiers`]+data PotentialUnifiers = NoUnifiers Canonical+                       -- NoUnifiers True: We have a unique solution modulo canonicity+                       -- NoUnifiers False: The solutions is not canonical, and thus+                       --   we shouldn't specialise on it.+                       | OneOrMoreUnifiers (NonEmpty 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. +{- 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 steps IL4 and 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`.+-}+ instance Outputable PotentialUnifiers where-  ppr NoUnifiers = text "NoUnifiers"+  ppr (NoUnifiers c) = text "NoUnifiers" <+> if c then text "canonical" else text "non-canonical"   ppr xs = ppr (getPotentialUnifiers 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 && c2)+  NoUnifiers _ <> u = u+  OneOrMoreUnifiers (unifier :| unifiers) <> u = OneOrMoreUnifiers (unifier :| (unifiers <> getPotentialUnifiers u))  getPotentialUnifiers :: PotentialUnifiers -> [ClsInst]-getPotentialUnifiers NoUnifiers = []-getPotentialUnifiers (OneOrMoreUnifiers cls) = cls+getPotentialUnifiers NoUnifiers{} = []+getPotentialUnifiers (OneOrMoreUnifiers cls) = NE.toList cls  nullUnifiers :: PotentialUnifiers -> Bool-nullUnifiers NoUnifiers = True+nullUnifiers NoUnifiers{} = True nullUnifiers _ = False  lookupInstEnv' :: InstEnv          -- InstEnv to look in@@ -900,14 +1073,21 @@       = acc  +    noncanonically_matched :: PotentialUnifiers -> PotentialUnifiers+    noncanonically_matched (NoUnifiers _) = NoUnifiers False+    noncanonically_matched u = u+     check_unifier :: [ClsInst] -> PotentialUnifiers-    check_unifier [] = NoUnifiers+    check_unifier [] = NoUnifiers True     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]+        -- Record that we encountered non-canonical instances: Note [Coherence and specialisation: overview]+      | isNonCanonical item+      = noncanonically_matched $ check_unifier items         -- Ignore ones that are incoherent: Note [Incoherent instances]       | isIncoherent item       = check_unifier items@@ -927,7 +1107,7 @@               -- See Note [Infinitary substitution in lookup]             MaybeApart MARInfinite _ -> check_unifier items             _                        ->-              OneOrMoreUnifiers (item: getPotentialUnifiers (check_unifier items))+              OneOrMoreUnifiers (item :| getPotentialUnifiers (check_unifier items))        where         tpl_tv_set = mkVarSet tpl_tvs@@ -952,8 +1132,8 @@   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+    all_matches = home_matches <> pkg_matches+    all_unifs   = home_unifs <> pkg_unifs     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@@ -967,7 +1147,7 @@      -- If the selected match is incoherent, discard all unifiers     final_unifs = case final_matches of-                    (m:_) | isIncoherent (fst m) -> NoUnifiers+                    (m:_) | isIncoherent (fst m) -> NoUnifiers True                     _                            -> all_unifs      -- Note [Safe Haskell isSafeOverlap]@@ -1145,7 +1325,7 @@ 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] pruneOverlappedMatches all_matches =   instMatches $ foldr insert_overlapping noMatches all_matches @@ -1298,7 +1478,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.  ************************************************************************ *                                                                      *
compiler/GHC/Core/Lint.hs view
@@ -31,7 +31,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) import GHC.Unit.Module.ModGuts@@ -56,7 +56,6 @@ 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@@ -303,6 +302,10 @@ 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).  ************************************************************************ *                                                                      *@@ -426,7 +429,7 @@                    -> IO () displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)   | not (isEmptyBag errs)-  = do { logMsg logger Err.MCDump noSrcSpan+  = 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 ***"@@ -437,9 +440,7 @@   | 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+  = logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]       $ withPprStyle defaultDumpStyle         (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -471,17 +472,15 @@      (_, dups) = removeDups compare binders -    -- dups_ext checks for names with different uniques+    -- 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 (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+    ext_dups = snd $ removeDupsOn ord_ext $+               filter isExternalName $ map Var.varName binders+    ord_ext n = (nameModule n, nameOccName n)  {- ************************************************************************@@ -1023,6 +1022,9 @@          ; checkDeadIdOcc var         ; checkJoinOcc var nargs+        ; case isDataConId_maybe var of+             Nothing -> return ()+             Just dc -> checkTypeDataConOcc "expression" dc          ; usage <- varCallSiteUsage var @@ -1109,6 +1111,13 @@   | 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)+ -- | 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.@@ -1187,13 +1196,13 @@ 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+    Just mult -> do+      let (lhs, body_ue') = popUE body_ue lam_var+          err_msg = text "Linearity failure in lambda:" <+> ppr lam_var+                    $$ ppr lhs <+> text "⊈" <+> ppr mult+      ensureSubUsage lhs mult err_msg+      return body_ue'     Nothing    -> return body_ue -- A type variable-  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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1544,17 +1553,24 @@             -> 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) =+lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) =   do { lintL (null args) (mkDefaultArgsMsg args)-     ; lintAltExpr rhs alt_ty }+     ; rhs_ue <- lintAltExpr rhs alt_ty+     ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr+           err_msg = text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr+                     $$ ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult+     ; ensureSubUsage case_bndr_usage scrut_mult err_msg+     ; return rhs_ue' } -lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs)+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 }+       ; rhs_ue <- lintAltExpr rhs alt_ty+       ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks+       }   where     lit_ty = literalType lit @@ -1563,10 +1579,11 @@   = 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)+    { 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@@ -2522,7 +2539,71 @@   = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h        ; lintCoercion (CoVarCo (coHoleCoVar h)) } + {-+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 }++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 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+++{- ************************************************************************ *                                                                      *               Axioms@@ -3112,9 +3193,14 @@  addInScopeId :: Id -> LintedType -> LintM a -> LintM a addInScopeId id linted_ty m-  = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set }) errs ->+  = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set, le_ue_aliases = aliases }) errs ->     unLintM m (env { le_ids   = extendVarEnv id_set id (id, linted_ty)-                   , le_joins = add_joins join_set }) errs+                   , le_joins = add_joins join_set+                   , le_ue_aliases = delFromNameEnv aliases (idName id) }) errs+                   -- When shadowing an alias, we need to make sure the Id is no longer+                   -- classified as such. E.g. in+                   -- let x = <e1> in case x of x { _DEFAULT -> <e2> }+                   -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.   where     add_joins join_set       | isJoinId id = extendVarSet join_set id -- Overwrite with new arity@@ -3157,7 +3243,7 @@   = 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+             -> do { checkL (not (bad_global id_bndr)) $ global_in_scope id_bndr                    ; return (id_bndr, linted_ty) }            Nothing -> do { checkL (not is_local) local_out_of_scope                          ; return (id_occ, idType id_occ) } }@@ -3166,8 +3252,10 @@   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)+    global_in_scope id_bndr = hang (text "Occurrence is GlobalId, but binding is LocalId")+                                 2 $ vcat [hang (text "occurrence:") 2 $ pprBndr LetBind id_occ+                                          ,hang (text "binder    :") 2 $ pprBndr LetBind id_bndr+                                          ]     bad_global id_bnd = isGlobalId id_occ                      && isLocalId id_bnd                      && not (isWiredIn id_occ)@@ -3201,7 +3289,7 @@ varCallSiteUsage id =   do m <- getUEAliases      return $ case lookupNameEnv m (getName id) of-         Nothing    -> unitUE id OneTy+         Nothing    -> singleUsageUE id          Just id_ue -> id_ue  ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
compiler/GHC/Core/Make.hs view
@@ -6,7 +6,7 @@         mkCoreLet, mkCoreLets,         mkCoreApp, mkCoreApps, mkCoreConApps,         mkCoreLams, mkWildCase, mkIfThenElse,-        mkWildValBinder, mkWildEvBinder,+        mkWildValBinder,         mkSingleAltCase,         sortQuantVars, castBottomExpr, @@ -54,7 +54,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@@ -173,9 +173,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@@ -559,7 +556,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   {-@@ -651,12 +649,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 +662,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)@@ -1082,8 +1080,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 +1206,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
compiler/GHC/Core/Map/Type.hs view
@@ -397,7 +397,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)
compiler/GHC/Core/Opt/Arity.hs view
@@ -134,6 +134,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 @@ -852,7 +855,7 @@  -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work-exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType+exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding --      e  ==>  \xy -> e x y -- Nothing if the expression has arity 0@@ -1873,7 +1876,7 @@   \(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@@ -3105,7 +3108,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 +3127,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)
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,113 @@+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 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 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/ConstantFold.hs view
@@ -27,6 +27,7 @@    ( primOpRules    , builtinRules    , caseRules+   , caseRules2    ) where @@ -55,7 +56,7 @@ import GHC.Core.TyCon    ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon    , isNewTyCon, tyConDataCons-   , tyConFamilySize )+   , tyConFamilySize, isTypeDataTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr )  import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )@@ -64,6 +65,9 @@ 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 ) @@ -120,7 +124,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 +155,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 +202,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 +233,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 +280,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 +311,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 +357,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 +388,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 +471,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 +525,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@@ -656,6 +680,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 +700,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 ]@@ -1118,6 +1151,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@@ -2652,6 +2829,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 @@ -2942,6 +3127,29 @@       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,12 +3160,13 @@  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 (Arg CoreBndr, Arg CoreBndr) 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@@ -3006,6 +3215,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 +3226,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 +3247,7 @@    { numAdd     = Word8AddOp    , numSub     = Word8SubOp    , numMul     = Word8MulOp+   , numDiv     = Just Word8QuotOp    , numAnd     = Just Word8AndOp    , numOr      = Just Word8OrOp    , numNeg     = Nothing@@ -3043,10 +3259,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 +3271,7 @@    { numAdd     = Word16AddOp    , numSub     = Word16SubOp    , numMul     = Word16MulOp+   , numDiv     = Just Word16QuotOp    , numAnd     = Just Word16AndOp    , numOr      = Just Word16OrOp    , numNeg     = Nothing@@ -3065,10 +3283,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 +3295,7 @@    { numAdd     = Word32AddOp    , numSub     = Word32SubOp    , numMul     = Word32MulOp+   , numDiv     = Just Word32QuotOp    , numAnd     = Just Word32AndOp    , numOr      = Just Word32OrOp    , numNeg     = Nothing@@ -3087,10 +3307,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 +3319,7 @@    { numAdd     = Word64AddOp    , numSub     = Word64SubOp    , numMul     = Word64MulOp+   , numDiv     = Just Word64QuotOp    , numAnd     = Just Word64AndOp    , numOr      = Just Word64OrOp    , numNeg     = Nothing@@ -3109,6 +3331,7 @@    { numAdd     = IntAddOp    , numSub     = IntSubOp    , numMul     = IntMulOp+   , numDiv     = Just IntQuotOp    , numAnd     = Just IntAndOp    , numOr      = Just IntOrOp    , numNeg     = Just IntNegOp@@ -3120,6 +3343,7 @@    { numAdd     = WordAddOp    , numSub     = WordSubOp    , numMul     = WordMulOp+   , numDiv     = Just WordQuotOp    , numAnd     = Just WordAndOp    , numOr      = Just WordOrOp    , numNeg     = Nothing@@ -3184,10 +3408,67 @@   | Just DataToTagOp <- isPrimOpId_maybe f   , Just (tc, _) <- tcSplitTyConApp_maybe ty   , isAlgTyCon tc+  , not (isTypeDataTyCon tc) -- See wrinkle (W2c) in GHC.Rename.Module+                             -- Note [Type data declarations]   = Just (v, tx_con_dtt ty            , \v -> App (App (Var f) (Type ty)) (Var v))  caseRules _ _ = Nothing+++-- | Case rules+--+-- It's important that occurence 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
compiler/GHC/Core/Opt/Monad.hs view
@@ -20,7 +20,7 @@     initRuleEnv, getExternalRuleBase,     getDynFlags, getPackageFamInstEnv,     getInteractiveContext,-    getUniqTag,+    getUniqMask,     getNamePprCtx, getSrcSpanM,      -- ** Writing to the monad@@ -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 )@@ -117,7 +117,7 @@         cr_name_ppr_ctx        :: NamePprCtx,         cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they                                              -- are at least tagged with the right source file-        cr_uniq_tag            :: !Char      -- Tag for creating unique values+        cr_uniq_mask           :: !Char      -- Mask for creating unique values }  -- Note: CoreWriter used to be defined with data, rather than newtype.  If it@@ -167,12 +167,12 @@  instance MonadUnique CoreM where     getUniqueSupplyM = do-        tag <- read cr_uniq_tag-        liftIO $! mkSplitUniqSupply tag+        mask <- read cr_uniq_mask+        liftIO $! mkSplitUniqSupply mask      getUniqueM = do-        tag <- read cr_uniq_tag-        liftIO $! uniqFromTag tag+        mask <- read cr_uniq_mask+        liftIO $! uniqFromMask mask  runCoreM :: HscEnv          -> RuleBase@@ -182,7 +182,7 @@          -> SrcSpan          -> CoreM a          -> IO (a, SimplCount)-runCoreM hsc_env rule_base tag mod name_ppr_ctx loc m+runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m   = liftM extract $ runIOEnv reader $ unCoreM m   where     reader = CoreReader {@@ -191,7 +191,7 @@             cr_module = mod,             cr_name_ppr_ctx = name_ppr_ctx,             cr_loc = loc,-            cr_uniq_tag = tag+            cr_uniq_mask = mask         }      extract :: (a, CoreWriter) -> (a, SimplCount)@@ -261,8 +261,8 @@ addSimplCount :: SimplCount -> CoreM () addSimplCount count = write (CoreWriter { cw_simpl_count = count }) -getUniqTag :: CoreM Char-getUniqTag = read cr_uniq_tag+getUniqMask :: CoreM Char+getUniqMask = read cr_uniq_mask  -- Convenience accessors for useful fields of HscEnv
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -59,7 +59,7 @@ import GHC.Unit.Module( Module )  import Data.List (mapAccumL, mapAccumR)-import Data.List.NonEmpty (NonEmpty (..), nonEmpty)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE  {-@@ -510,6 +510,16 @@     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@@ -608,6 +618,65 @@ '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@@ -618,8 +687,10 @@  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.+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: @@ -636,15 +707,32 @@ 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.+* Note that the join arity of the RHS and that of the unfolding or RULE might+  mismatch: -  In the non-recursive case things are simple: see occAnalNonRecBind+    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@@ -669,28 +757,21 @@   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.+  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:@@ -707,26 +788,39 @@ 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.+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'. -Thus the overall sequence taking place in 'occAnalNonRecBind' and-'occAnalRecBind' is as follows:+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 'occAnalLamOrRhs' to find usage information for the RHS.-  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+  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.-  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when-     recursive.)--(In the recursive case, this logic is spread between 'makeNode' and-'occAnalRec'.)+     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' -} - data WithUsageDetails a = WithUsageDetails !UsageDetails !a +data WithTailUsageDetails a = WithTailUsageDetails !TailUsageDetails !a+ ------------------------------------------------------------------ --                 occAnalBind ------------------------------------------------------------------@@ -750,19 +844,17 @@   | 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 []+  | not (bndr `usedIn` body_usage)+  = WithUsageDetails body_usage [] -- See Note [Dead code]    | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr rhs']+  = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr final_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+    WithUsageDetails body_usage' tagged_bndr = tagNonRecBinder lvl body_usage bndr      -- Get the join info from the *new* decision     -- See Note [Join points and unfoldings/rules]+    -- => join arity O of Note [Join arity prediction based on joinRhsArity]     mb_join_arity = willBeJoinId_maybe tagged_bndr     is_join_point = isJust mb_join_arity @@ -773,17 +865,28 @@      -- 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+    -- 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+    WithUsageDetails adj_rhs_uds final_rhs+      = adjustNonRecRhs mb_join_arity $ occAnalLamTail rhs_env rhs+    rhs_usage = adj_rhs_uds `andUDs` adj_unf_uds `andUDs` adj_rule_uds+    final_bndr = tagged_bndr `setIdSpecialisation` mkRuleInfo rules'+                             `setIdUnfolding` unf2      --------- Unfolding ----------    -- See Note [Unfoldings and join points]+    -- See Note [Join points and unfoldings/rules]     unf | isId bndr = idUnfolding bndr         | otherwise = NoUnfolding-    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf+    WithTailUsageDetails unf_uds unf1 = occAnalUnfolding rhs_env unf+    unf2 = markNonRecUnfoldingOneShots mb_join_arity unf1+    adj_unf_uds = adjustTailArity mb_join_arity unf_uds      --------- Rules ---------     -- See Note [Rules are extra RHSs] and Note [Rule dependency info]-    rules_w_uds  = occAnalRules rhs_env mb_join_arity bndr+    -- and Note [Join points and unfoldings/rules]+    rules_w_uds  = occAnalRules rhs_env bndr     rules'       = map fstOf3 rules_w_uds     imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)          -- imp_rule_uds: consider@@ -794,8 +897,9 @@          -- 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+    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds+      = l `andUDs` adjustTailArity mb_join_arity r `andUDs` uds      ----------     occ = idOccInfo tagged_bndr@@ -820,7 +924,7 @@ occAnalRecBind !env lvl imp_rule_edges pairs body_usage   = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs   where-    sccs :: [SCC Details]+    sccs :: [SCC NodeDetails]     sccs = {-# SCC "occAnalBind.scc" #-}            stronglyConnCompFromEdgedVerticesUniq nodes @@ -832,48 +936,62 @@     bndr_set = mkVarSet bndrs     rhs_env  = env `addInScope` bndrs +adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr+-- ^ This function concentrates shared logic between occAnalNonRecBind and the+-- AcyclicSCC case of occAnalRec.+--   * It applies 'markNonRecJoinOneShots' to the RHS+--   * and returns the adjusted rhs UsageDetails combined with the body usage+adjustNonRecRhs mb_join_arity (WithTailUsageDetails rhs_tuds rhs)+  = WithUsageDetails rhs_uds' rhs'+  where+    --------- Marking (non-rec) join binders one-shot ---------+    !rhs' | Just ja <- mb_join_arity = markNonRecJoinOneShots ja rhs+          | otherwise                = rhs+    --------- Adjusting right-hand side usage ---------+    rhs_uds' = adjustTailUsage mb_join_arity rhs' rhs_tuds +bindersOfSCC :: SCC NodeDetails -> [Var]+bindersOfSCC (AcyclicSCC nd) = [nd_bndr nd]+bindersOfSCC (CyclicSCC ds)  = map nd_bndr ds+ ----------------------------- occAnalRec :: OccEnv -> TopLevelFlag-           -> SCC Details+           -> 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 = rhs-                                  , nd_uds = rhs_uds }))-           (WithUsageDetails body_uds binds)-  | not (bndr `usedIn` body_uds)-  = WithUsageDetails body_uds binds -- See Note [Dead code]+-- Check for Note [Dead code]+-- NB: Only look at body_uds, ignoring uses in the SCC+occAnalRec !_ _ scc (WithUsageDetails body_uds binds)+  | not (any (`usedIn` body_uds) (bindersOfSCC scc))+  = WithUsageDetails body_uds binds -  | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_uds' `andUDs` rhs_uds')-                     (NonRec tagged_bndr rhs : binds)+-- The NonRec case is just like a Let (NonRec ...) above+occAnalRec !_ lvl+           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))+           (WithUsageDetails body_uds binds)+  = WithUsageDetails (body_uds' `andUDs` rhs_uds') (NonRec bndr' rhs' : binds)   where-    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr-    rhs_uds'      = adjustRhsUsage mb_join_arity rhs rhs_uds+    WithUsageDetails body_uds' tagged_bndr = tagNonRecBinder lvl body_uds bndr     mb_join_arity = willBeJoinId_maybe tagged_bndr+    WithUsageDetails rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds+    !unf'  = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)+    !bndr' = tagged_bndr `setIdUnfolding` unf' -        -- The Rec case is the interesting one-        -- See Note [Recursive bindings: the grand plan]-        -- See Note [Loop breaking]+-- 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]+    loop_breaker_nodes :: [LoopBreakerNode]     (WithUsageDetails final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s      ------------------------------@@ -1102,7 +1220,7 @@ loopBreakNodes :: Int                -> VarSet        -- Binders whose dependencies may be "missing"                                 -- See Note [Weak loop breakers]-               -> [LetrecNode]+               -> [LoopBreakerNode]                -> [Binding]             -- Append these to the end                -> [Binding] @@ -1121,7 +1239,7 @@           CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds  -----------------------------------reOrderNodes :: Int -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]+reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]     -- Choose a loop breaker, mark it no-inline,     -- and call loopBreakNodes on the rest reOrderNodes _ _ []     _     = panic "reOrderNodes"@@ -1133,7 +1251,7 @@     (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)   where     (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb-                                                 (nd_score (node_payload node))+                                                 (snd_score (node_payload node))                                                  [node] [] nodes      approximate_lb = depth >= 2@@ -1142,8 +1260,8 @@         -- 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})+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@@ -1163,13 +1281,13 @@     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])+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 []@@ -1189,7 +1307,7 @@   | 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)+    sc = snd_score (node_payload node)  {- Note [Complexity of loop breaking]@@ -1322,16 +1440,21 @@ ************************************************************************ -} -type LetrecNode = Node Unique Details  -- Node comes from Digraph-                                       -- The Unique key is gotten from the Id-data Details-  = ND { nd_bndr :: Id          -- Binder+-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'.+-- The Unique key is gotten from the Id.+type LetrecNode = Node Unique NodeDetails -       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed+-- | Node details as consumed by 'occAnalRec'.+data NodeDetails+  = ND { nd_bndr :: Id          -- Binder -       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings-                                  -- ignoring phase (ie assuming all are active)-                                  -- See Note [Forming Rec groups]+       , 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@@ -1348,20 +1471,35 @@        , 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+instance Outputable NodeDetails where    ppr nd = text "ND" <> braces              (sep [ text "bndr =" <+> ppr (nd_bndr nd)-                  , text "uds =" <+> ppr (nd_uds 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)-                  , text "score =" <+> ppr (nd_score nd)              ])+            where WithTailUsageDetails 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@@ -1387,52 +1525,59 @@     -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.   where     details = ND { nd_bndr            = bndr'-                 , nd_rhs             = rhs'-                 , nd_uds             = scope_uds+                 , nd_rhs             = WithTailUsageDetails 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-                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }+                 , nd_active_rule_fvs = active_rule_fvs }      bndr' = bndr `setIdUnfolding`      unf'                  `setIdSpecialisation` mkRuleInfo rules' -    inl_uds = rhs_uds `andUDs` unf_uds-    scope_uds = inl_uds `andUDs` rule_uds+    -- 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+    scope_uds       = TUD rhs_ja unadj_scope_uds                    -- Note [Rules are extra RHSs]                    -- Note [Rule dependency info]-    scope_fvs = udFreeVars bndr_set scope_uds+    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 inl_uds+    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 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+    -- 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 = rhsCtxt env+    WithTailUsageDetails (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs+      -- corresponding call to adjustTailUsage in occAnalRec and tagRecBinders      --------- Unfolding ----------    -- See Note [Unfoldings and join points]+    -- See Note [Join points and unfoldings/rules]     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+    WithTailUsageDetails unf_tuds unf' = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity (Just 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@@ -1441,11 +1586,15 @@     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 = occAnalRules rhs_env mb_join_arity bndr+    rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_tuds)+                  | (r,l,rhs_tuds) <- occAnalRules rhs_env bndr ]     rules'      = map fstOf3 rules_w_uds -    rule_uds = foldr add_rule_uds imp_rule_uds 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 ------------@@ -1463,8 +1612,8 @@  mkLoopBreakerNodes :: OccEnv -> TopLevelFlag                    -> UsageDetails   -- for BODY of let-                   -> [Details]-                   -> WithUsageDetails [LetrecNode] -- adjusted+                   -> [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:@@ -1477,10 +1626,10 @@ 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+    WithUsageDetails 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+      = DigraphNode { node_payload      = simple_nd                     , node_key          = varUnique old_bndr                     , node_dependencies = nonDetKeysUniqSet lb_deps }               -- It's OK to use nonDetKeysUniqSet here as@@ -1488,7 +1637,8 @@               -- 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 }+        WithTailUsageDetails _ rhs = nd_rhs nd+        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]@@ -1524,10 +1674,10 @@ nodeScore :: OccEnv           -> Id        -- Binder with new occ-info           -> VarSet    -- Loop-breaker dependencies-          -> Details+          -> NodeDetails           -> NodeScore nodeScore !env new_bndr lb_deps-          (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })+          (ND { nd_bndr = old_bndr, nd_rhs = WithTailUsageDetails _ bind_rhs })    | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker   = (100, 0, False)@@ -1748,7 +1898,7 @@  * 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.+  lambda-group.  See occAnalLamTail.  * Simplifier.  The simplifier is careful when partially applying   lambda-groups. See the call to zapLambdaBndrs in@@ -1804,25 +1954,31 @@     zap_bndr b | isTyVar b = b                | otherwise = zapLamIdInfo b -occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)--- See Note [Occurrence analysis for lambda binders]+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, either in occAnal (Lam {}), or in adjustRhsUsage+-- 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]--occAnalLam env (Lam bndr expr)+occAnalLamTail env (Lam bndr expr)   | isTyVar bndr-  = let env1 = addOneInScope env bndr-        WithUsageDetails usage expr' = occAnalLam env1 expr-    in WithUsageDetails usage (Lam bndr expr')+  , let env1 = addOneInScope env bndr+  , WithTailUsageDetails (TUD ja usage) expr' <- occAnalLamTail env1 expr+  = WithTailUsageDetails (TUD (ja+1) 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@@ -1840,14 +1996,14 @@          env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }         env2 = addOneInScope env1 bndr-        (WithUsageDetails usage expr') = occAnalLam env2 expr+        WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env2 expr         (usage', bndr2) = tagLamBinder usage bndr1-    in WithUsageDetails usage' (Lam bndr2 expr')+    in WithTailUsageDetails (TUD (ja+1) 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+occAnalLamTail env (Cast expr co)+  = let  WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env expr          -- usage1: see Note [Gather occurrences of coercion variables]          usage1 = addManyOccs usage (coVarsOfCo co) @@ -1857,15 +2013,16 @@                     _ -> 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+         -- 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 WithUsageDetails usage3 (Cast expr' co)+    in WithTailUsageDetails (TUD ja usage3) (Cast expr' co) -occAnalLam env expr = occAnal env expr+occAnalLamTail env expr = case occAnal env expr of+  WithUsageDetails usage expr' -> WithTailUsageDetails (TUD 0 usage) expr'  {- Note [Occ-anal and cast worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1885,8 +2042,8 @@ 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.+We only need to this in occAnalLamTail, not occAnal, because the top leve+of a right hand side is handled by occAnalLamTail. -}  @@ -1896,57 +2053,23 @@ *                                                                      * ********************************************************************* -} -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+                 -> WithTailUsageDetails Unfolding -- Occurrence-analyse a stable unfolding;--- discard a non-stable one altogether.-occAnalUnfolding !env is_rec mb_join_arity unf+-- 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-              (WithUsageDetails usage rhs') = occAnalRhs env is_rec mb_join_arity rhs+              WithTailUsageDetails (TUD rhs_ja usage) rhs' = occAnalLamTail env rhs                unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]                    | otherwise         = unf { uf_tmpl = rhs' }-            in WithUsageDetails (markAllMany usage) unf'+            in WithTailUsageDetails (TUD rhs_ja (markAllMany usage)) unf'               -- markAllMany: see Note [Occurrences in stable unfoldings]-        | otherwise          -> WithUsageDetails emptyDetails unf+        | otherwise          -> WithTailUsageDetails (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@@ -1955,29 +2078,26 @@               -- scope remain in scope; there is no cloning etc.        unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-        -> WithUsageDetails final_usage (unf { df_args = args' })+        -> WithTailUsageDetails (TUD 0 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+          final_usage     = usage `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+      unf -> WithTailUsageDetails (TUD 0 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+                  TailUsageDetails)] -- Usage details for RHS+occAnalRules !env 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')+      = (rule', lhs_uds', TUD rhs_ja rhs_uds')       where         env' = env `addInScope` bndrs         rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]@@ -1990,14 +2110,11 @@         (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' = markAllMany $                    rhs_uds `delDetailsList` bndrs--        exact_join = exactJoin mb_join_arity args-                     -- See Note [Join points and unfoldings/rules]+        rhs_ja = length args -- See Note [Join points and unfoldings/rules] -    occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails)+    occ_anal_rule other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)  {- Note [Join point RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2032,6 +2149,8 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2220,10 +2339,7 @@   = 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'+  = adjustNonRecRhs Nothing $ occAnalLamTail env expr -- mb_join_arity == Nothing <=> markAllManyNonTail  occAnal env (Case scrut bndr ty alts)   = let@@ -2298,7 +2414,7 @@   --     This caused #18296   | fun `hasKey` runRWKey   , [t1, t2, arg]  <- args-  , let (WithUsageDetails usage arg') = occAnalRhs env NonRecursive (Just 1) arg+  , WithUsageDetails usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg   = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])  occAnalApp env (Var fun_id, args, ticks)@@ -2883,7 +2999,6 @@     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@@ -3009,6 +3124,19 @@ instance Outputable UsageDetails where   ppr ud = ppr (ud_env (flattenUsageDetails ud)) +-- | Captures the result of applying 'occAnalLamTail' to a function `\xyz.body`.+-- The TailUsageDetails records+--   * the number of lambdas (including type lambdas: a JoinArity)+--   * UsageDetails for the `body`, 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++ ------------------- -- UsageDetails API @@ -3150,25 +3278,50 @@  ------------------- -- See Note [Adjusting right-hand sides]-adjustRhsUsage :: Maybe JoinArity-               -> CoreExpr       -- Rhs, AFTER occ anal-               -> UsageDetails   -- From body of lambda+adjustTailUsage :: Maybe JoinArity+               -> CoreExpr           -- Rhs, AFTER occAnalLamTail+               -> TailUsageDetails   -- From body of lambda                -> UsageDetails-adjustRhsUsage mb_join_arity rhs usage+adjustTailUsage mb_join_arity rhs (TUD rhs_ja 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+    exact_join = mb_join_arity == Just rhs_ja -exactJoin :: Maybe JoinArity -> [a] -> Bool-exactJoin Nothing           _    = False-exactJoin (Just join_arity) args = args `lengthIs` join_arity-  -- Remember join_arity includes type binders+adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails+adjustTailArity mb_rhs_ja (TUD ud_ja usage) =+  markAllNonTailIf (mb_rhs_ja /= Just ud_ja) usage +markNonRecJoinOneShots :: 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+markNonRecJoinOneShots 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.)++markNonRecUnfoldingOneShots :: Maybe JoinArity -> Unfolding -> Unfolding+-- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding+markNonRecUnfoldingOneShots mb_join_arity unf+  | Just ja <- mb_join_arity+  , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf+  , isStableSource src+  , let !tmpl' = markNonRecJoinOneShots ja tmpl+  = unf{uf_tmpl=tmpl'}+  | otherwise+  = unf+ type IdWithOccInfo = Id  tagLamBinders :: UsageDetails          -- Of scope@@ -3203,8 +3356,8 @@ tagNonRecBinder :: TopLevelFlag           -- At top level?                 -> UsageDetails           -- Of scope                 -> CoreBndr               -- Binder-                -> (UsageDetails,         -- Details with binder removed-                    IdWithOccInfo)        -- Tagged binder+                -> WithUsageDetails       -- Details with binder removed+                    IdWithOccInfo         -- Tagged binder  tagNonRecBinder lvl usage binder  = let@@ -3216,37 +3369,34 @@      binder' = setBinderOcc occ' binder      usage'  = usage `delDetails` binder    in-   usage' `seq` (usage', binder')+   WithUsageDetails usage' binder'  tagRecBinders :: TopLevelFlag           -- At top level?               -> UsageDetails           -- Of body of let ONLY-              -> [Details]-              -> (UsageDetails,         -- Adjusted details for whole scope,+              -> [NodeDetails]+              -> WithUsageDetails       -- Adjusted details for whole scope,                                         -- with binders removed-                  [IdWithOccInfo])      -- Tagged binders+                  [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)+     -- 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=WithTailUsageDetails tuds rhs}+       = adjustTailArity (Just (joinRhsArity rhs)) tuds -     -- 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 ]+     bndr_ne = expectNonEmpty "List of binders is never empty" bndrs+     will_be_joins = decideJoinPointHood lvl unadj_uds bndr_ne       mb_join_arity :: Id -> Maybe JoinArity+     -- 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!)@@ -3258,6 +3408,12 @@        = assert (not will_be_joins) -- Should be AlwaysTailCalled if          Nothing                   -- 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 rhs_tuds -- matching occAnalLamTail in makeNode+                 | ND { nd_bndr = bndr, nd_rhs = WithTailUsageDetails rhs_tuds rhs }+                     <- details_s ]+      -- 3. Compute final usage details from adjusted RHS details      adj_uds   = foldr andUDs body_uds rhs_udss' @@ -3268,7 +3424,7 @@      -- 5. Drop the binders from the adjusted details and return      usage'    = adj_uds `delDetailsList` bndrs    in-   (usage', bndrs')+   WithUsageDetails usage' bndrs'  setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr setBinderOcc occ_info bndr@@ -3282,12 +3438,13 @@    | otherwise = setIdOccInfo bndr occ_info --- | Decide whether some bindings should be made into join points or not.+-- | 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',+-- 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'.
+ compiler/GHC/Core/Opt/Simplify/Inline.hs view
@@ -0,0 +1,555 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998++This module contains inlining logic used by the simplifier.+-}+++{-# LANGUAGE BangPatterns #-}++module GHC.Core.Opt.Simplify.Inline (+        -- * Cheap and cheerful inlining checks.+        couldBeSmallEnoughToInline,+        smallEnoughToInline,++        -- * The smart inlining decisions are made by callSiteInline+        callSiteInline, CallCtxt(..),+    ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Unfold+import GHC.Types.Id+import GHC.Types.Basic  ( Arity, RecFlag(..) )+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 :: 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/Opt/Simplify/Iteration.hs view
@@ -19,9 +19,11 @@  import GHC.Core import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.ConstantFold 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.Inline import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutBinderSwap_maybe ) import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )@@ -62,7 +64,7 @@ import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey ) -import GHC.Data.Maybe   ( isNothing, orElse )+import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName ) import GHC.Utils.Outputable@@ -595,9 +597,9 @@                         --            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]+  , isConcreteType (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@@ -666,7 +668,7 @@ 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"+  = 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]@@ -1434,7 +1436,7 @@    simplTickish env tickish     | Breakpoint ext n ids <- tickish-          = Breakpoint ext n (map (getDoneId . substId env) ids)+          = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids)     | otherwise = tickish    -- Push type application and coercion inside a tick@@ -1445,8 +1447,9 @@     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 (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]@@ -2226,44 +2229,34 @@             (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.+  , [ TyArg {}, TyArg {} ] <- rev_args+  -- Do this even if (contIsStop cont)   -- 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]+             ty'   = contResultType cont         -- 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#]+       -- 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.        ; arg' <- case arg of            Lam s body -> do { (env', s') <- simplBinder arg_env s-                            ; body' <- simplExprC env' body inner_cont+                            ; body' <- simplExprC env' body 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 }+                                            , sc_env = env', sc_cont = cont+                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy 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 }+       ; let rr'   = getRuntimeRep ty'+             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']+       ; return (emptyFloats env, call') }  ---------- Simplify value arguments -------------------- rebuildCall env fun_info@@ -2276,8 +2269,7 @@    -- 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]+  , seCaseCase env   = -- 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@@ -3049,6 +3041,14 @@        ; case mb_rule of            Just (env', rule_rhs, cont') -> simplExprF 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@@ -3086,9 +3086,7 @@ --------------------------------------------------  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]+  | not (seCaseCase env)   = do { case_expr <- simplAlts env scrut case_bndr alts                                 (mkBoringStop (contHoleType cont))        ; rebuild env case_expr cont }
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -180,13 +180,13 @@ ************************************************************************ -} --- See Note [Uniques for wired-in prelude things and known tags] in GHC.Builtin.Uniques-simplTag :: Char-simplTag = 's'+-- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques+simplMask :: Char+simplMask = 's'  instance MonadUnique SimplM where-    getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplTag-    getUniqueM = liftIO $ uniqFromTag simplTag+    getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask+    getUniqueM = liftIO $ uniqFromMask simplMask  instance HasLogger SimplM where     getLogger = gets st_logger
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -43,10 +43,12 @@     ) 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 import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr@@ -83,7 +85,6 @@  import Control.Monad    ( when ) import Data.List        ( sortBy )-import qualified Data.List as Partial ( head )  {- ********************************************************************* *                                                                      *@@ -687,7 +688,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.@@ -1858,11 +1859,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]@@ -2141,6 +2143,9 @@         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
compiler/GHC/Core/Ppr.hs view
@@ -159,9 +159,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
compiler/GHC/Core/Predicate.hs view
@@ -16,16 +16,16 @@   getEqPredTys, getEqPredTys_maybe, getEqPredRole,   predTypeEqRel,   mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-  mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,+  mkNomPrimEqPred,    -- Class predicates   mkClassPred, isDictTy, typeDeterminesValue,-  isClassPred, isEqPredClass, isCTupleClass,+  isClassPred, isEqualityClass, isCTupleClass,   getClassPredTys, getClassPredTys_maybe,   classMethodTy, classMethodInstTy,    -- Implicit parameters-  isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,+  isIPLikePred, mentionsIP, isIPTyCon, isIPClass,   isCallStackTy, isCallStackPred, isCallStackPredTy,   isIPPred_maybe, @@ -38,6 +38,7 @@  import GHC.Core.Type import GHC.Core.Class+import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Types.Var@@ -51,8 +52,6 @@ import GHC.Utils.Panic import GHC.Data.FastString -import Control.Monad ( guard )- -- | A predicate in the solver. The solver tries to prove Wanted predicates -- from Given ones. data Pred@@ -68,7 +67,7 @@    -- | 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@@ -100,14 +99,7 @@ mkClassPred clas tys = mkTyConApp (classTyCon clas) tys  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]@@ -207,7 +199,7 @@ {- Note [Evidence for quantified constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The superclass mechanism in GHC.Tc.Solver.Canonical.makeSuperClasses risks+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@@ -216,7 +208,7 @@ 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.+in GHC.Tc.Solver.Dict. -}  isEvVarType :: Type -> Bool@@ -226,27 +218,32 @@ -- 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 :: PredType -> Bool isClassPred ty = case tyConAppTyCon_maybe ty of-    Just tyCon | isClassTyCon tyCon -> True-    _                               -> False+    Just tc -> isClassTyCon tc+    _       -> False +isEqPred :: PredType -> Bool 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+  = isEqualityClass cls   | otherwise   = False +isEqPrimPred :: PredType -> Bool isEqPrimPred ty = isCoVarType ty   -- True of (a ~# b) (a ~R# b) +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) @@ -263,39 +260,15 @@ isIPClass :: Class -> Bool isIPClass cls = cls `hasKey` ipClassKey -isIPLikePred :: Type -> Bool--- See Note [Local implicit parameters]-isIPLikePred = is_ip_like_pred initIPRecTc---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-+-- | 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-  = 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--initIPRecTc :: RecTcChecker-initIPRecTc = setRecTcMaxBound 1 initRecTc+  = Nothing  -- --------------------- CallStack predicates --------------------------------- @@ -329,18 +302,49 @@   | otherwise   = False +-- --------------------- isIPLike and mentionsIP  --------------------------+--                 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)+isIPLikePred :: Type -> Bool+-- Is `pred`, or any of its superclasses, an implicit parameter?+-- See Note [Local implicit parameters]+isIPLikePred pred = mentions_ip_pred initIPRecTc Nothing pred +mentionsIP :: Type -> Class -> [Type] -> Bool+-- Is (cls tys) an implicit parameter with key `str_ty`, or+-- is any of its superclasses such at thing.+-- See Note [Local implicit parameters]+mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys++mentions_ip :: RecTcChecker -> Maybe Type -> Class -> [Type] -> Bool+mentions_ip rec_clss mb_str_ty cls tys+  | Just (str_ty', _) <- isIPPred_maybe cls tys+  = case mb_str_ty of+       Nothing -> True+       Just str_ty -> str_ty `eqType` str_ty'+  | otherwise+  = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys)+       | sc_sel_id <- classSCSelIds cls ]++mentions_ip_pred :: RecTcChecker -> Maybe Type -> Type -> Bool+mentions_ip_pred  rec_clss mb_str_ty ty+  | Just (cls, tys) <- getClassPredTys_maybe ty+  , let tc = classTyCon cls+  , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss+                      else checkRecTc rec_clss tc+  = mentions_ip rec_clss' mb_str_ty 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in+GHC.Tc.Solver.Dict.+ The function isIPLikePred tells if this predicate, or any of its superclasses, is an implicit parameter.
compiler/GHC/Core/Reduction.hs view
@@ -361,8 +361,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,
compiler/GHC/Core/Rules.hs view
@@ -41,7 +41,7 @@ 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@@ -62,7 +62,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,6 +84,7 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag+import GHC.Data.List.SetOps( hasNoDups )  import GHC.Utils.Misc as Utils import GHC.Utils.Outputable@@ -892,8 +894,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                     }@@ -1070,6 +1077,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 overlp 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 polymoprhic 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'@@ -1378,7 +1544,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 +1564,7 @@          -- because no free var of e2' is in the rnEnvR of the envt  ------------------------------------------+ match_ty :: RuleMatchEnv          -> RuleSubst          -> Type                -- Template@@ -1409,12 +1576,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/SimpleOpt.hs view
@@ -497,14 +497,21 @@        | 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+ ------------------- simple_out_bind :: TopLevelFlag                 -> SimpleOptEnv@@ -1078,6 +1085,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@@ -1228,7 +1274,7 @@        = go subst floats fun (CC (subst_expr subst arg : args) co)      go subst floats (Lam bndr body) (CC (arg:args) co)-       | exprIsTrivial arg          -- Don't duplicate stuff!+       | do_beta_by_substitution bndr arg        = go (extend subst bndr arg) floats body (CC args co)        | otherwise        = let (subst', bndr') = subst_bndr subst bndr
compiler/GHC/Core/Subst.hs view
@@ -417,11 +417,12 @@ cloneIdBndrs subst us ids   = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) -cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])+cloneBndrs :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var]) -- Works for all kinds of variables (typically case binders) -- not just Ids-cloneBndrs subst us vs-  = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)+cloneBndrs subst vs+  = do us <- getUniquesM+       pure $ mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` us)  cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) cloneBndr subst uniq v@@ -429,12 +430,11 @@   | otherwise = clone_id subst subst (v,uniq)  -- Works for coercion variables too  -- | 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 :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id])+cloneRecIdBndrs subst ids+  = do us <- getUniquesM+       let (subst', ids') = mapAccumL (clone_id subst') subst (ids `zip` us)+       pure (subst', ids')  -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use@@ -592,9 +592,9 @@ ------------------ substTickish :: Subst -> CoreTickish -> CoreTickish substTickish subst (Breakpoint ext n ids)-   = Breakpoint ext n (map do_one ids)+   = Breakpoint ext n (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 +649,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/TyCo/Compare.hs view
@@ -324,7 +324,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@@ -379,7 +379,7 @@  * GHC.Core.Types.eqType  * GHC.Core.Types.nonDetCmpType  * GHC.Core.Unify.unify_ty- * TcCanonical.can_eq_nc'+ * GHC.Tc.Solver.Equality.can_eq_nc'  * TcUnify.uType  This optimisation is especially helpful for the ubiquitous GHC.Types.Type,
compiler/GHC/Core/TyCo/FVs.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE MultiWayIf #-}  module GHC.Core.TyCo.FVs   (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,@@ -23,7 +23,7 @@         almostDevoidCoVarOfCo,          -- Injective free vars-        injectiveVarsOfType, injectiveVarsOfTypes,+        injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType,         invisibleVarsOfType, invisibleVarsOfTypes,          -- Any and No Free vars@@ -53,7 +53,7 @@  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 )@@ -806,6 +806,28 @@ *                                                                      * ********************************************************************* -} +isInjectiveInType :: TyVar -> Type -> Bool+-- True <=> tv /definitely/ appears injectively in ty+-- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty)+-- Ignore occurence 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,24 +858,29 @@                     -> 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:
compiler/GHC/Core/TyCo/Rep.hs view
@@ -38,7 +38,7 @@         -- * Coercions         Coercion(..), CoSel(..), FunSel(..),         UnivCoProvenance(..),-        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar, isHeteroKindCoHole,         CoercionN, CoercionR, CoercionP, KindCoercion,         MCoercion(..), MCoercionR, MCoercionN, @@ -61,7 +61,7 @@         TyCoFolder(..), foldTyCo, noView,          -- * Sizes-        typeSize, coercionSize, provSize,+        typeSize, typesSize, coercionSize, provSize,          -- * Multiplicities         Scaled(..), scaledMult, scaledThing, mapScaledType, Mult@@ -325,113 +325,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@@ -1561,12 +1454,20 @@   = CoercionHole { ch_co_var  :: CoVar                        -- See Note [CoercionHoles and coercion free variables] -                 , ch_ref     :: IORef (Maybe Coercion)+                 , ch_ref :: IORef (Maybe Coercion)++                 , ch_hetero_kind :: Bool+                       -- True <=> arises from a kind-level equality+                       -- See Note [Equalities with incompatible kinds]+                       --     in GHC.Tc.Solver.Equality, wrinkle (EIK2)                  }  coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var +isHeteroKindCoHole :: CoercionHole -> Bool+isHeteroKindCoHole = ch_hetero_kind+ setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole setCoHoleCoVar h cv = h { ch_co_var = cv } @@ -1577,7 +1478,8 @@   dataTypeOf _ = mkNoRepType "CoercionHole"  instance Outputable CoercionHole where-  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)+  ppr (CoercionHole { ch_co_var = cv, ch_hetero_kind = hk })+    = braces (ppr cv <> ppWhen hk (text "[hk]"))  instance Uniquable CoercionHole where   getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv@@ -1893,14 +1795,19 @@ --     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
compiler/GHC/Core/TyCo/Rep.hs-boot view
@@ -8,6 +8,7 @@  data Type data Coercion+data FunSel data CoSel data UnivCoProvenance data TyLit
compiler/GHC/Core/TyCo/Subst.hs view
@@ -387,9 +387,9 @@ --   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
compiler/GHC/Core/TyCon.hs view
@@ -20,12 +20,13 @@         PromDataConInfo(..), TyConFlavour(..),          -- * TyConBinder-        TyConBinder, TyConBndrVis(..), TyConPiTyBinder,+        TyConBinder, TyConBndrVis(..),         mkNamedTyConBinder, mkNamedTyConBinders,         mkRequiredTyConBinder,-        mkAnonTyConBinder, mkAnonTyConBinders, mkInvisAnonTyConBinder,+        mkAnonTyConBinder, mkAnonTyConBinders,         tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder,-        isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis,+        isVisibleTyConBinder, isInvisibleTyConBinder,+        isVisibleTcbVis, isInvisSpecTcbVis,          -- ** Field labels         tyConFieldLabels, lookupTyConFieldLabel,@@ -123,7 +124,7 @@         tyConRepModOcc,          -- * Primitive representations of Types-        PrimRep(..), PrimElemRep(..),+        PrimRep(..), PrimElemRep(..), Levity(..),         primElemRepToPrimRep,         isVoidRep, isGcPtrRep,         primRepSizeB,@@ -194,7 +195,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 +211,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 +230,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 +322,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 +428,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 +446,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) $@@ -499,10 +491,8 @@ 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,8 +507,12 @@  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+ isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)@@ -530,7 +524,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 +543,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 +553,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 +577,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:@@ -645,7 +609,7 @@ {- 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 +620,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 +637,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,12 +709,12 @@   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) } }  @@ -766,15 +730,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 +838,17 @@                                  --          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,  -- 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 +885,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 +910,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 +929,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1301,16 +1263,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.@@ -1574,8 +1536,7 @@ -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep   = VoidRep-  | LiftedRep-  | UnliftedRep   -- ^ Unlifted pointer+  | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value   | Int32Rep      -- ^ Signed, 32-bit value@@ -1586,7 +1547,7 @@   | 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@@ -1613,42 +1574,47 @@  instance Binary PrimRep where   put_ bh VoidRep        = putByte bh 0-  put_ bh LiftedRep      = putByte bh 1-  put_ bh UnliftedRep    = putByte bh 2-  put_ bh Int8Rep        = putByte bh 3-  put_ bh Int16Rep       = putByte bh 4-  put_ bh Int32Rep       = putByte bh 5-  put_ bh Int64Rep       = putByte bh 6-  put_ bh IntRep         = putByte bh 7-  put_ bh Word8Rep       = putByte bh 8-  put_ bh Word16Rep      = putByte bh 9-  put_ bh Word32Rep      = putByte bh 10-  put_ bh Word64Rep      = putByte bh 11-  put_ bh WordRep        = putByte bh 12-  put_ bh AddrRep        = putByte bh 13-  put_ bh FloatRep       = putByte bh 14-  put_ bh DoubleRep      = putByte bh 15-  put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per+  put_ bh (BoxedRep ml)  = case ml of+    -- cheaper storage of the levity than using+    -- the Binary (Maybe Levity) instance+    Nothing       -> putByte bh 1+    Just Lifted   -> putByte bh 2+    Just Unlifted -> putByte bh 3+  put_ bh Int8Rep        = putByte bh 4+  put_ bh Int16Rep       = putByte bh 5+  put_ bh Int32Rep       = putByte bh 6+  put_ bh Int64Rep       = putByte bh 7+  put_ bh IntRep         = putByte bh 8+  put_ bh Word8Rep       = putByte bh 9+  put_ bh Word16Rep      = putByte bh 10+  put_ bh Word32Rep      = putByte bh 11+  put_ bh Word64Rep      = putByte bh 12+  put_ bh WordRep        = putByte bh 13+  put_ bh AddrRep        = putByte bh 14+  put_ bh FloatRep       = putByte bh 15+  put_ bh DoubleRep      = putByte bh 16+  put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per   get  bh = do     h <- getByte bh     case h of       0  -> pure VoidRep-      1  -> pure LiftedRep-      2  -> pure UnliftedRep-      3  -> pure Int8Rep-      4  -> pure Int16Rep-      5  -> pure Int32Rep-      6  -> pure Int64Rep-      7  -> pure IntRep-      8  -> pure Word8Rep-      9  -> pure Word16Rep-      10 -> pure Word32Rep-      11 -> pure Word64Rep-      12 -> pure WordRep-      13 -> pure AddrRep-      14 -> pure FloatRep-      15 -> pure DoubleRep-      16 -> VecRep <$> get bh <*> get bh+      1  -> pure $ BoxedRep Nothing+      2  -> pure $ BoxedRep (Just Lifted)+      3  -> pure $ BoxedRep (Just Unlifted)+      4  -> pure Int8Rep+      5  -> pure Int16Rep+      6  -> pure Int32Rep+      7  -> pure Int64Rep+      8  -> pure IntRep+      9  -> pure Word8Rep+      10 -> pure Word16Rep+      11 -> pure Word32Rep+      12 -> pure Word64Rep+      13 -> pure WordRep+      14 -> pure AddrRep+      15 -> pure FloatRep+      16 -> pure DoubleRep+      17 -> VecRep <$> get bh <*> get bh       _  -> pprPanic "Binary:PrimRep" (int (fromIntegral h))  instance Binary PrimElemRep where@@ -1660,9 +1626,8 @@ 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,8 +1668,7 @@    FloatRep         -> fLOAT_SIZE    DoubleRep        -> dOUBLE_SIZE    AddrRep          -> platformWordSizeInBytes platform-   LiftedRep        -> platformWordSizeInBytes platform-   UnliftedRep      -> platformWordSizeInBytes platform+   BoxedRep _       -> platformWordSizeInBytes platform    VoidRep          -> 0    (VecRep len rep) -> len * primElemRepSizeB platform rep @@ -1886,15 +1850,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) $@@ -1922,13 +1884,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 +1912,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 $@@ -2018,18 +1984,17 @@ -- (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   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 (AlgTyCon {algTcRhs = rhs})   Representational = isGenInjAlgRhs rhs     go (SynonymTyCon {})             _                = False     go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })-                                                  Nominal          = True+                                                  Nominal = True     go (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj     go (FamilyTyCon {})              _                = False     go (PrimTyCon {})                _                = True@@ -2037,13 +2002,17 @@     go (TcTyCon {})                  _                = True    -- Reply True for TcTyCon to minimise knock on type errors-  -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl+  -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl   -- | '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@@ -2167,13 +2136,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 +2163,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 +2196,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@@ -2403,30 +2366,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@@ -2774,43 +2731,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@@ -2825,8 +2746,8 @@    | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details   = case flav of-      DataFamilyTyCon{}            -> DataFamilyFlavour parent-      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour parent+      DataFamilyTyCon{}            -> OpenFamilyFlavour IAmData parent+      OpenSynFamilyTyCon           -> OpenFamilyFlavour IAmType parent       ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour       AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour       BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour@@ -2837,24 +2758,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
compiler/GHC/Core/TyCon/Env.hs view
@@ -100,7 +100,7 @@ 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)
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@@ -76,6 +76,7 @@          mkCastTy, mkCoercionTy, splitCastTy_maybe, +        ErrorMsgType,         userTypeError_maybe, pprUserTypeErrorTy,          coAxNthLHS,@@ -110,6 +111,7 @@         isTyVarTy, isFunTy, isCoercionTy,         isCoercionTy_maybe, isForAllTy,         isForAllTy_ty, isForAllTy_co,+        isForAllTy_invis_ty,         isPiTy, isTauTy, isFamFreeTy,         isCoVarType, isAtomicTy, @@ -132,8 +134,9 @@         isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,         kindBoxedRepLevity_maybe,         mightBeLiftedType, mightBeUnliftedType,+        definitelyLiftedType, definitelyUnliftedType,         isAlgType, isDataFamilyAppType,-        isPrimitiveType, isStrictType,+        isPrimitiveType, isStrictType, isTerminatingType,         isLevityTy, isLevityVar,         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,         dropRuntimeRepArgs,@@ -183,7 +186,7 @@         seqType, seqTypes,          -- * Other views onto Types-        coreView,+        coreView, coreFullView, rewriterView,          tyConsOfType, @@ -232,7 +235,7 @@          -- * Kinds         isTYPEorCONSTRAINT,-        isConcrete, isFixedRuntimeRepKind,+        isConcreteType, isFixedRuntimeRepKind,     ) where  import GHC.Prelude@@ -272,7 +275,7 @@    , mkTyConAppCo, mkAppCo    , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo    , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo-   , mkKindCo, mkSubCo, mkFunCo1+   , mkKindCo, mkSubCo, mkFunCo, funRole    , decomposePiCos, coercionKind    , coercionRKind, coercionType    , isReflexiveCo, seqCo@@ -360,6 +363,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 +417,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 @@ -686,8 +706,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 +790,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 +799,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 +814,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@@ -867,7 +890,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,10 +904,10 @@  {-# 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)@@ -894,7 +918,7 @@          -> ( 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 +926,20 @@                      , 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+    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 +951,36 @@       | 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+    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 (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_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 (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)       | isTcTyCon tc       = do { tc' <- tycon tc            ; mkTyConAppCo r tc' <$> go_cos env cos }@@ -967,17 +991,17 @@        | otherwise       = mkTyConAppCo r tc <$> go_cos env cos-    go_co env (ForAllCo tv kind_co co)+    go_co !env (ForAllCo tv kind_co co)       = do { kind_co' <- go_co env kind_co-           ; (env', tv') <- tycobinder env tv Inferred+           ; tycobinder env tv Inferred $ \env' tv' ->  do            ; co' <- go_co env' co            ; return $ mkForAllCo tv' 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+    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   {- *********************************************************************@@ -1028,7 +1052,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@@ -1208,9 +1232,12 @@   | 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+-- If so, give us the error message.+userTypeError_maybe :: Type -> Maybe ErrorMsgType userTypeError_maybe t   = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t           -- There may be more than 2 arguments, if the type error is@@ -1220,7 +1247,7 @@        ; return msg }  -- | 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 +1273,6 @@     -- An unevaluated type function     _ -> ppr ty - {- ********************************************************************* *                                                                      *                       FunTy@@ -1307,9 +1333,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)@@ -1592,7 +1621,7 @@ -- (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+--     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 --@@ -1732,7 +1761,7 @@ 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@@ -1794,7 +1823,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 +1892,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@@ -2195,32 +2233,33 @@ 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- 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     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+    is_concrete  = uniqSetAll isConcreteTyCon rhs_tycons+         -- NB: is_concrete is allowed to be conservative, returning False+         --     more often than it could.  e.g.+         --       type S a b = b+         --       type family F a+         --       type T a = S (F a) a+         -- We will mark T as not-concrete, even though (since S ignore its first+         -- argument, it could be marked concrete.++    is_forgetful = not (all ((`elemVarSet` rhs_tyvars) . binderVar) binders) ||+                   uniqSetAny isForgetfulSynTyCon rhs_tycons+         -- NB: is_forgetful is allowed to be conservative, returning True more often          -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon +    rhs_tycons = tyConsOfType   rhs+    rhs_tyvars = tyCoVarsOfType rhs+ {- ************************************************************************ *                                                                      *@@ -2253,8 +2292,7 @@   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 +2302,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 +2313,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@@ -2368,6 +2412,28 @@ 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 (isNewTyCon tc)+    _       -> False++-- | 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+ isPrimitiveType :: Type -> Bool -- ^ Returns true of types that are opaque to Haskell. isPrimitiveType ty = case splitTyConApp_maybe ty of@@ -2489,8 +2555,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 +2573,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] @@ -2737,29 +2797,26 @@     (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 = go   where-    go ty | Just ty' <- coreView ty = go ty'     go (TyVarTy tv)        = isConcreteTyVar tv     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 +2825,22 @@     go CastTy{}            = False     go CoercionTy{}        = False +    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 +2887,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`
compiler/GHC/Core/Type.hs-boot view
@@ -21,7 +21,8 @@ typeKind :: HasDebugCallStack => Type -> Type typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint -coreView :: Type -> Maybe Type+coreView       :: Type -> Maybe Type+rewriterView   :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool isLevityTy :: Type -> Bool isMultiplicityTy :: Type -> Bool
compiler/GHC/Core/Unfold.hs view
@@ -21,25 +21,22 @@ 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     ) where  import GHC.Prelude -import GHC.Driver.Flags- import GHC.Core import GHC.Core.Utils import GHC.Types.Id@@ -48,21 +45,17 @@ import GHC.Builtin.PrimOps import GHC.Types.Id.Info import GHC.Types.RepType ( isZeroBitTy )-import GHC.Types.Basic  ( Arity, RecFlag(..) )+import GHC.Types.Basic  ( Arity, RecFlag ) import GHC.Core.Type 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) - -- | Unfolding options data UnfoldingOpts = UnfoldingOpts    { unfoldingCreationThreshold :: !Int@@ -151,6 +144,41 @@ updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts updateReportPrefix n opts = opts { unfoldingReportPrefix = n } +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"+ {- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -565,7 +593,7 @@            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+           ClassOpId {}     -> classOpSize opts top_args val_args            _                -> funSize opts top_args fun (length val_args) voids      ------------@@ -930,561 +958,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/Unify.hs view
@@ -31,7 +31,6 @@ 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@@ -734,8 +733,8 @@ 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 ~.+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@@ -1151,10 +1150,8 @@   -- 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)+  | Just {} <- sORTKind_maybe ty1+  , Just {} <- sORTKind_maybe ty2   = maybeApart MARTypeVsConstraint     -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim     -- Note [Type and Constraint are not apart]@@ -1433,13 +1430,16 @@ 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)+{-# 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))
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@@ -97,6 +104,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
@@ -23,9 +23,9 @@         -- * Properties of expressions         exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,         mkFunctionType,-        exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,-        trivial_expr_fold,-        exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,+        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr,+        getIdFromTrivialExpr_maybe,+        exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,         exprIsWorkFree, exprIsConLike,         isCheapApp, isExpandableApp, isSaturatedConApp,@@ -91,8 +91,7 @@ import GHC.Types.Tickish import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Types.Basic( Arity, Levity(..)-                       )+import GHC.Types.Basic( Arity ) import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Demand@@ -141,8 +140,7 @@ exprType e@(App _ _)   = case collectArgs e of         (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args--exprType other = pprPanic "exprType" (pprCoreExpr other)+exprType (Type ty) = pprPanic "exprType" (ppr ty)  coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side@@ -847,8 +845,9 @@            __DEFAULT -> ()    Namely, we do _not_ want to match on `A`, as it doesn't exist at the value-  level!+  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@@ -1047,37 +1046,20 @@ 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+-- If you modify this function, you may also+-- need to modify getIdFromTrivialExpr+exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]+exprIsTrivial (Type _)         = True+exprIsTrivial (Coercion _)     = True+exprIsTrivial (Lit lit)        = litIsTrivial lit+exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e+exprIsTrivial (Lam b e)        = not (isRuntimeVar b) && exprIsTrivial e+exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e+                                 -- See Note [Tick trivial]+exprIsTrivial (Cast e _)       = exprIsTrivial e+exprIsTrivial (Case e _ _ [])  = exprIsTrivial e  -- See Note [Empty case is trivial]+exprIsTrivial _                = False  {- Note [getIdFromTrivialExpr]@@ -1097,13 +1079,24 @@ -}  getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id+getIdFromTrivialExpr e+    = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))+                (getIdFromTrivialExpr_maybe e)++getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id -- See Note [getIdFromTrivialExpr]-getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e+-- Th equations for this should line up with those for exprIsTrivial+getIdFromTrivialExpr_maybe e+  = go e   where-    panic = pprPanic "getIdFromTrivialExpr" (ppr e)+    go (App f t) | not (isRuntimeArg t)   = go f+    go (Tick t e) | not (tickishIsCode t) = go e+    go (Cast e _)                         = go e+    go (Lam b e) | not (isRuntimeVar b)   = go e+    go (Case e _ _ [])                    = go e+    go (Var v) = Just v+    go _       = Nothing -getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id-getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e  {- ********************************************************************* *                                                                      *@@ -1613,10 +1606,19 @@                 -- been expressed by its "wrapper", so we don't need                 -- to take the arguments into account +      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-        , [arg1, Lit lit] <- args-        -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1+        , Lit divisor <- last args+            -- there can be 2 args (most div primops) or 3 args+            -- (WordQuotRem2Op), hence the use of last/init+        -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (init args)               -- Special case for dividing operations that fail               -- In general they are NOT ok-for-speculation               -- (which primop_ok will catch), but they ARE OK@@ -1635,14 +1637,16 @@         -> 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)+      _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  -- 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.+            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.)           -- Partial applications          | idArity fun > n_val_args ->@@ -1657,14 +1661,15 @@              --     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 (idType fun)+    (arg_tys, _) = splitPiTys fun_ty      -- 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)+       | definitelyLiftedType (scaledThing ty)        = True -- See Note [Primops with lifted arguments]        | otherwise        = expr_ok fun_ok primop_ok arg@@ -1694,8 +1699,36 @@   = hasNoBinding id &&     ( tickishFloatable t || isProfTick t ) -{- Note [exprOkForSpeculation: case expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- 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@@ -1920,7 +1953,8 @@         -- 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 )++      || definitelyUnliftedType (idType v)         -- Unlifted binders are always evaluated (#20140)      is_hnf_like (Lit l)          = not (isLitRubbish l)@@ -2091,9 +2125,8 @@     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+        mkUserLocalOrCoVar (mkVarOccFS fs) uniq+                           (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan  {- Note [Mark evaluated arguments]
compiler/GHC/CoreToIface.hs view
@@ -49,8 +49,6 @@  import GHC.Prelude -import Data.Word- import GHC.StgToCmm.Types  import GHC.ByteCode.Types@@ -87,6 +85,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.Maybe ( isNothing, catMaybes )@@ -359,12 +358,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)@@ -455,14 +450,15 @@  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@@ -580,7 +576,7 @@ 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 (SourceNote src (LexicalFastString names))  = Just (IfaceSource src names) toIfaceTickish (Breakpoint {})         = Nothing    -- Ignore breakpoints, since they are relevant only to GHCi, and    -- should not be serialised (#8333)@@ -664,7 +660,7 @@                                       -- Foreign calls have special syntax      | isExternalName name             = IfaceExt name-    | otherwise                       = IfaceLcl (getOccFS name)+    | otherwise                       = IfaceLcl (occNameFS $ nameOccName name)   where     name = idName v     ty   = idType v@@ -700,7 +696,7 @@  -- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> Type -> CgBreakInfo+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo dehydrateCgBreakInfo ty_vars idOffSets tick_ty =           CgBreakInfo             { cgb_tyvars = map toIfaceTvBndr ty_vars
compiler/GHC/Data/Bag.hs view
@@ -12,14 +12,14 @@         Bag, -- abstract type          emptyBag, unitBag, unionBags, unionManyBags,-        mapBag,+        mapBag, pprBag,         elemBag, lengthBag,         filterBag, partitionBag, partitionBagWith,         concatBag, catBagMaybes, foldBag,         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,7 +38,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) )-import Control.DeepSeq+import Control.Applicative( Alternative( (<|>) ) )  infixr 3 `consBag` infixl 3 `snocBag`@@ -50,12 +50,6 @@   | ListBag (NonEmpty a)   deriving (Foldable, Functor, Traversable) -instance NFData a => NFData (Bag a) where-  rnf EmptyBag = ()-  rnf (UnitBag a) = rnf a-  rnf (TwoBags a b) = rnf a `seq` rnf b-  rnf (ListBag a) = rnf a- emptyBag :: Bag a emptyBag = EmptyBag @@ -121,7 +115,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 +147,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@@ -228,6 +235,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 +255,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 +273,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 +285,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 +297,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 +323,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 +355,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
@@ -24,8 +24,7 @@  import GHC.Utils.Monad import GHC.Utils.Outputable-import GHC.Utils.Binary-import GHC.Parser.Annotation ( LocatedL, noLocA )+import GHC.Parser.Annotation ( LocatedL ) import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set@@ -243,22 +242,3 @@     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/FastString.hs view
@@ -52,6 +52,9 @@         fastStringToShortByteString,         mkFastStringShortByteString, +        -- * ShortText+        fastStringToShortText,+         -- * FastZString         FastZString,         hPutFZS,@@ -130,6 +133,7 @@ #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@@ -159,6 +163,9 @@ fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs +fastStringToShortText :: FastString -> ShortText+fastStringToShortText = ShortText . fs_sbs+ fastZStringToByteString :: FastZString -> ByteString fastZStringToByteString (FastZString bs) = bs @@ -412,7 +419,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
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)++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/Graph/Directed.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}  module GHC.Data.Graph.Directed (         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,@@ -45,7 +46,7 @@  import GHC.Prelude -import GHC.Utils.Misc ( sortWith, count )+import GHC.Utils.Misc ( minWith, count ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust )@@ -108,7 +109,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@@ -218,52 +219,47 @@      [payload])         -- Rest of the path;                         --  [a,b,c] means c depends on b, b depends on a --- | Find a reasonably short cycle a->b->c->a, in a graph--- The graph might not necessarily be strongly connected.+-- | Find a reasonably short cycle a->b->c->a, in a strongly+-- connected component.  The input nodes are presumed to be+-- a SCC, so you can start anywhere. findCycle :: forall payload key. Ord key           => [Node key payload]     -- The nodes.  The dependencies can                                     -- contain extra keys, which are ignored           -> Maybe [payload]        -- A cycle, starting with node                                     -- so each depends on the next findCycle graph-  = goRoots plausible_roots+  = go Set.empty (new_work root_deps []) []   where     env :: Map.Map key (Node key payload)     env = Map.fromList [ (node_key node, node) | node <- graph ] -    goRoots [] = Nothing-    goRoots (root:xs) =-        case go Set.empty (new_work root_deps []) [] of-          Nothing -> goRoots xs-          Just res -> Just res-      where-        DigraphNode root_payload root_key root_deps = root-        -- 'go' implements Dijkstra's algorithm, more or less-        go :: Set.Set key   -- Visited-           -> [WorkItem key payload]        -- Work list, items length n-           -> [WorkItem key payload]        -- Work list, items length n+1-           -> Maybe [payload]               -- Returned cycle-           -- Invariant: in a call (go visited ps qs),-           --            visited = union (map tail (ps ++ qs))--        go _       [] [] = Nothing  -- No cycles-        go visited [] qs = go visited qs []-        go visited (((DigraphNode payload key deps), path) : ps) qs-           | key == root_key           = Just (root_payload : reverse path)-           | key `Set.member` visited  = go visited ps qs-           | key `Map.notMember` env   = go visited ps qs-           | otherwise                 = go (Set.insert key visited)-                                            ps (new_qs ++ qs)-           where-             new_qs = new_work deps (payload : path)+    -- Find the node with fewest dependencies among the SCC modules+    -- This is just a heuristic to find some plausible root module+    root :: Node key payload+    root = fst (minWith snd [ (node, count (`Map.member` env)+                                           (node_dependencies node))+                            | node <- graph ])+    DigraphNode root_payload root_key root_deps = root  -    -- Find the nodes with fewest dependencies among the SCC modules-    -- This is just a heuristic to find some plausible root module-    plausible_roots :: [Node key payload]-    plausible_roots = map fst (sortWith snd [ (node, count (`Map.member` env) (node_dependencies node))-                                            | node <- graph ])+    -- 'go' implements Dijkstra's algorithm, more or less+    go :: Set.Set key   -- Visited+       -> [WorkItem key payload]        -- Work list, items length n+       -> [WorkItem key payload]        -- Work list, items length n+1+       -> Maybe [payload]               -- Returned cycle+       -- Invariant: in a call (go visited ps qs),+       --            visited = union (map tail (ps ++ qs)) +    go _       [] [] = Nothing  -- No cycles+    go visited [] qs = go visited qs []+    go visited (((DigraphNode payload key deps), path) : ps) qs+       | key == root_key           = Just (root_payload : reverse path)+       | key `Set.member` visited  = go visited ps qs+       | key `Map.notMember` env   = go visited ps qs+       | otherwise                 = go (Set.insert key visited)+                                        ps (new_qs ++ qs)+       where+         new_qs = new_work deps (payload : path)      new_work :: [key] -> [payload] -> [WorkItem key payload]     new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
compiler/GHC/Data/Graph/UnVar.hs view
@@ -35,9 +35,8 @@ import GHC.Types.Var import GHC.Utils.Outputable import GHC.Types.Unique-import GHC.Word -import qualified GHC.Data.Word64Set as S+import qualified Data.IntSet as S  -- We need a type for sets of variables (UnVarSet). -- We do not use VarSet, because for that we need to have the actual variable@@ -45,10 +44,10 @@ -- Therefore, use a IntSet directly (which is likely also a bit more efficient).  -- Set of uniques, i.e. for adjacent nodes-newtype UnVarSet = UnVarSet S.Word64Set+newtype UnVarSet = UnVarSet (S.IntSet)     deriving Eq -k :: Var -> Word64+k :: Var -> Int k v = getKey (getUnique v)  domUFMUnVarSet :: UniqFM key elt -> UnVarSet@@ -93,7 +92,7 @@  instance Outputable UnVarSet where     ppr (UnVarSet s) = braces $-        hcat $ punctuate comma [ ppr (mkUniqueGrimily i) | i <- S.toList s]+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]  data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph                 | CG    !UnVarSet           -- ^ complete graph
compiler/GHC/Data/IOEnv.hs view
@@ -28,13 +28,13 @@         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@@ -226,12 +226,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''.
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
@@ -35,6 +35,7 @@ import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack) import Data.List.NonEmpty ( NonEmpty )+import Control.Applicative( Alternative( (<|>) ) )  infixr 4 `orElse` @@ -47,7 +48,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.
− compiler/GHC/Data/Word64Map.hs 
@@ -1,61 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MonoLocalBinds #-}-#endif----------------------------------------------------------------------------------- |--- Module      :  Data.Word64Map--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ An efficient implementation of maps from integer keys to values--- (dictionaries).------ This module re-exports the value lazy "Data.Word64Map.Lazy" API, plus--- several deprecated value strict functions. Please note that these functions--- have different strictness properties than those in "Data.Word64Map.Strict":--- they only evaluate the result of the combining function. For example, the--- default value to 'insertWith'' is only evaluated if the combining function--- is called and uses it.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import Data.Word64Map (Word64Map)--- >  import qualified Data.Word64Map as Word64Map------ The implementation is based on /big-endian patricia trees/.  This data--- structure performs especially well on binary operations like 'union'--- and 'intersection'.  However, my benchmarks show that it is also--- (much) faster on insertions and deletions when compared to a generic--- size-balanced map implementation (see "Data.Map").------    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",---      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.------ Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.--- Many operations have a worst-case complexity of \(O(\min(n,64))\).--- This means that the operation can become linear in the number of--- elements with a maximum of \(64\)--------------------------------------------------------------------------------module GHC.Data.Word64Map-    ( module GHC.Data.Word64Map.Lazy-    ) where--import GHC.Data.Word64Map.Lazy
− compiler/GHC/Data/Word64Map/Internal.hs 
@@ -1,3606 +0,0 @@-{-# 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 #-}----------------------------------------------------------------------------------- |--- Module      :  Data.Word64Map.Internal--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008---                (c) wren romano 2016--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ The contents of this module may change __in any way whatsoever__--- and __without any warning__ between minor versions of this package.------ Authors importing this module are expected to track development--- closely.------ = Description------ This defines the data structures and core (hidden) manipulations--- on representations.------ @since 0.5.9---------------------------------------------------------------------------------- [Note: INLINE bit fiddling]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- It is essential that the bit fiddling functions like mask, zero, branchMask--- etc are inlined. If they do not, the memory allocation skyrockets. The GHC--- usually gets it right, but it is disastrous if it does not. Therefore we--- explicitly mark these functions INLINE.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Care must be taken when using 'go' function which captures an argument.--- Sometimes (for example when the argument is passed to a data constructor,--- as in insert), GHC heap-allocates more than necessary. Therefore C-- code--- must be checked for increased allocation when creating and modifying such--- functions.----- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of Word64Map matters when considering performance.--- Currently in GHC 7.0, when type has 3 constructors, they are matched from--- the first to the last -- the best performance is achieved when the--- constructors are ordered by frequency.--- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil--- improves the benchmark by circa 10%.-----module GHC.Data.Word64Map.Internal (-    -- * Map type-      Word64Map(..), Key          -- instance Eq,Show--    -- * Operators-    , (!), (!?), (\\)--    -- * Query-    , null-    , size-    , member-    , notMember-    , lookup-    , findWithDefault-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE-    , disjoint--    -- * Construction-    , empty-    , singleton--    -- ** Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- ** Delete\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** Compose-    , compose--    -- ** General combining function-    , SimpleWhenMissing-    , SimpleWhenMatched-    , runWhenMatched-    , runWhenMissing-    , merge-    -- *** @WhenMatched@ tactics-    , zipWithMaybeMatched-    , zipWithMatched-    -- *** @WhenMissing@ tactics-    , mapMaybeMissing-    , dropMissing-    , preserveMissing-    , mapMissing-    , filterMissing--    -- ** Applicative general combining function-    , WhenMissing (..)-    , WhenMatched (..)-    , mergeA-    -- *** @WhenMatched@ tactics-    -- | The tactics described for 'merge' work for-    -- 'mergeA' as well. Furthermore, the following-    -- are available.-    , zipWithMaybeAMatched-    , zipWithAMatched-    -- *** @WhenMissing@ tactics-    -- | The tactics described for 'merge' work for-    -- 'mergeA' as well. Furthermore, the following-    -- are available.-    , traverseMaybeMissing-    , traverseMissing-    , filterAMissing--    -- ** Deprecated general combining function-    , mergeWithKey-    , mergeWithKey'--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet-    , fromSet--    -- ** Lists-    , toList-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** Ordered lists-    , toAscList-    , toDescList-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--    -- * Debugging-    , showTree-    , showTreeWith--    -- * Internal types-    , Mask, Prefix, Nat--    -- * Utility-    , natFromInt-    , intFromNat-    , link-    , linkWithMask-    , bin-    , binCheckLeft-    , binCheckRight-    , zero-    , nomatch-    , match-    , mask-    , maskW-    , shorter-    , branchMask-    , highestBitMask--    -- * Used by "Word64Map.Merge.Lazy" and "Word64Map.Merge.Strict"-    , mapWhenMissing-    , mapWhenMatched-    , lmapWhenMissing-    , contramapFirstWhenMatched-    , contramapSecondWhenMatched-    , mapGentlyWhenMissing-    , mapGentlyWhenMatched-    ) where--import GHC.Prelude.Basic hiding-  (lookup, filter, foldr, foldl, foldl', null, map)--import Data.Functor.Identity (Identity (..))-import Data.Semigroup (Semigroup(stimes,(<>)),stimesIdempotentMonoid)-import Data.Functor.Classes--import Control.DeepSeq (NFData(rnf))-import qualified Data.Foldable as Foldable-import Data.Maybe (fromMaybe)--import GHC.Data.Word64Set.Internal (Key)-import qualified GHC.Data.Word64Set.Internal as Word64Set-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----- A "Nat" is a 64 bit machine word (an unsigned Int64)-type Nat = Word64--natFromInt :: Key -> Nat-natFromInt = id-{-# INLINE natFromInt #-}--intFromNat :: Nat -> Key-intFromNat = id-{-# INLINE intFromNat #-}--{---------------------------------------------------------------------  Types---------------------------------------------------------------------}----- | A map of integers to values @a@.---- See Note: Order of constructors-data Word64Map a = Bin {-# UNPACK #-} !Prefix-                    {-# UNPACK #-} !Mask-                    !(Word64Map a)-                    !(Word64Map a)--- Fields:---   prefix: The most significant bits shared by all keys in this Bin.---   mask: The switching bit to determine if a key should follow the left---         or right subtree of a 'Bin'.--- Invariant: Nil is never found as a child of Bin.--- Invariant: The Mask is a power of 2. It is the largest bit position at which---            two keys of the map differ.--- Invariant: Prefix is the common high-order bits that all elements share to---            the left of the Mask bit.--- Invariant: In (Bin prefix mask left right), left consists of the elements that---            don't have the mask bit set; right is all the elements that do.-              | Tip {-# UNPACK #-} !Key a-              | Nil--type Prefix = Word64-type Mask   = Word64----- Some stuff from "Data.Word64Set.Internal", for 'restrictKeys' and--- 'withoutKeys' to use.-type Word64SetPrefix = Word64-type Word64SetBitMap = Word64--bitmapOf :: Word64 -> Word64SetBitMap-bitmapOf x = shiftLL 1 (fromIntegral (x .&. Word64Set.suffixBitMask))-{-# INLINE bitmapOf #-}--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}---- | \(O(\min(n,W))\). Find the value at a key.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'--(!) :: Word64Map a -> Key -> a-(!) m k = find k m---- | \(O(\min(n,W))\). Find the value at a key.--- Returns 'Nothing' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] !? 1 == Nothing--- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'------ @since 0.5.11--(!?) :: Word64Map a -> Key -> Maybe a-(!?) m k = lookup k m---- | Same as 'difference'.-(\\) :: Word64Map a -> Word64Map b -> Word64Map a-m1 \\ m2 = difference m1 m2--infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}--{---------------------------------------------------------------------  Types---------------------------------------------------------------------}--instance Monoid (Word64Map a) where-    mempty  = empty-    mconcat = unions-    mappend = (<>)---- | @since 0.5.7-instance Semigroup (Word64Map a) where-    (<>)    = union-    stimes  = stimesIdempotentMonoid---- | Folds in order of increasing key.-instance Foldable.Foldable Word64Map where-  fold = go-    where go Nil = mempty-          go (Tip _ v) = v-          go (Bin _ m l r)-            | m < 0     = go r `mappend` go l-            | otherwise = go l `mappend` go r-  {-# INLINABLE fold #-}-  foldr = foldr-  {-# INLINE foldr #-}-  foldl = foldl-  {-# INLINE foldl #-}-  foldMap f t = go t-    where go Nil = mempty-          go (Tip _ v) = f v-          go (Bin _ m l r)-            | m < 0     = go r `mappend` go l-            | otherwise = go l `mappend` go r-  {-# INLINE foldMap #-}-  foldl' = foldl'-  {-# INLINE foldl' #-}-  foldr' = foldr'-  {-# INLINE foldr' #-}-  length = size-  {-# INLINE length #-}-  null   = null-  {-# INLINE null #-}-  toList = elems -- NB: Foldable.toList /= Word64Map.toList-  {-# INLINE toList #-}-  elem = go-    where go !_ Nil = False-          go x (Tip _ y) = x == y-          go x (Bin _ _ l r) = go x l || go x r-  {-# INLINABLE elem #-}-  maximum = start-    where start Nil = error "Data.Foldable.maximum (for Data.Word64Map): empty map"-          start (Tip _ y) = y-          start (Bin _ m l r)-            | m < 0     = go (start r) l-            | otherwise = go (start l) r--          go !m Nil = m-          go m (Tip _ y) = max m y-          go m (Bin _ _ l r) = go (go m l) r-  {-# INLINABLE maximum #-}-  minimum = start-    where start Nil = error "Data.Foldable.minimum (for Data.Word64Map): empty map"-          start (Tip _ y) = y-          start (Bin _ m l r)-            | m < 0     = go (start r) l-            | otherwise = go (start l) r--          go !m Nil = m-          go m (Tip _ y) = min m y-          go m (Bin _ _ l r) = go (go m l) r-  {-# INLINABLE minimum #-}-  sum = foldl' (+) 0-  {-# INLINABLE sum #-}-  product = foldl' (*) 1-  {-# INLINABLE product #-}---- | Traverses in order of increasing key.-instance Traversable Word64Map where-    traverse f = traverseWithKey (\_ -> f)-    {-# INLINE traverse #-}--instance NFData a => NFData (Word64Map a) where-    rnf Nil = ()-    rnf (Tip _ v) = rnf v-    rnf (Bin _ _ l r) = rnf l `seq` rnf r--#if __GLASGOW_HASKELL__--{---------------------------------------------------------------------  A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data a => Data (Word64Map a) where-  gfoldl f z im = z fromList `f` (toList im)-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = intMapDataType-  dataCast1 f    = gcast1 f--fromListConstr :: Constr-fromListConstr = mkConstr intMapDataType "fromList" [] Prefix--intMapDataType :: DataType-intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | \(O(1)\). Is the map empty?------ > Data.Word64Map.null (empty)           == True--- > Data.Word64Map.null (singleton 1 'a') == False--null :: Word64Map a -> Bool-null Nil = True-null _   = False-{-# INLINE null #-}---- | \(O(n)\). Number of elements in the map.------ > size empty                                   == 0--- > size (singleton 1 'a')                       == 1--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3-size :: Word64Map a -> Int-size = go 0-  where-    go !acc (Bin _ _ l r) = go (go acc l) r-    go acc (Tip _ _) = 1 + acc-    go acc Nil = acc---- | \(O(\min(n,W))\). Is the key a member of the map?------ > member 5 (fromList [(5,'a'), (3,'b')]) == True--- > member 1 (fromList [(5,'a'), (3,'b')]) == False---- See Note: Local 'go' functions and capturing]-member :: Key -> Word64Map a -> Bool-member !k = go-  where-    go (Bin p m l r) | nomatch k p m = False-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx _) = k == kx-    go Nil = False---- | \(O(\min(n,W))\). Is the key not a member of the map?------ > notMember 5 (fromList [(5,'a'), (3,'b')]) == False--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True--notMember :: Key -> Word64Map a -> Bool-notMember k m = not $ member k m---- | \(O(\min(n,W))\). Lookup the value at a key in the map. See also 'Data.Map.lookup'.---- See Note: Local 'go' functions and capturing-lookup :: Key -> Word64Map a -> Maybe a-lookup !k = go-  where-    go (Bin _p m l r) | zero k m  = go l-                      | otherwise = go r-    go (Tip kx x) | k == kx   = Just x-                  | otherwise = Nothing-    go Nil = Nothing---- See Note: Local 'go' functions and capturing]-find :: Key -> Word64Map a -> a-find !k = go-  where-    go (Bin _p m l r) | zero k m  = go l-                      | otherwise = go r-    go (Tip kx x) | k == kx   = x-                  | otherwise = not_found-    go Nil = not_found--    not_found = error ("Word64Map.!: key " ++ show k ++ " is not an element of the map")---- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@--- returns the value at key @k@ or returns @def@ when the key is not an--- element of the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See Note: Local 'go' functions and capturing]-findWithDefault :: a -> Key -> Word64Map a -> a-findWithDefault def !k = go-  where-    go (Bin p m l r) | nomatch k p m = def-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx x) | k == kx   = x-                  | otherwise = def-    go Nil = def---- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the--- corresponding (key, value) pair.------ > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')---- See Note: Local 'go' functions and capturing.-lookupLT :: Key -> Word64Map a -> Maybe (Key, a)-lookupLT !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r-      | zero k m  = go def l-      | otherwise = go l r-    go def (Tip ky y)-      | k <= ky   = unsafeFindMax def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMax def---- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the--- corresponding (key, value) pair.------ > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGT :: Key -> Word64Map a -> Maybe (Key, a)-lookupGT !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def-      | zero k m  = go r l-      | otherwise = go def r-    go def (Tip ky y)-      | k >= ky   = unsafeFindMin def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMin def---- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')---- See Note: Local 'go' functions and capturing.-lookupLE :: Key -> Word64Map a -> Maybe (Key, a)-lookupLE !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r-      | zero k m  = go def l-      | otherwise = go l r-    go def (Tip ky y)-      | k < ky    = unsafeFindMax def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMax def---- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGE :: Key -> Word64Map a -> Maybe (Key, a)-lookupGE !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def-      | zero k m  = go r l-      | otherwise = go def r-    go def (Tip ky y)-      | k > ky    = unsafeFindMin def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMin def----- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMin :: Word64Map a -> Maybe (Key, a)-unsafeFindMin Nil = Nothing-unsafeFindMin (Tip ky y) = Just (ky, y)-unsafeFindMin (Bin _ _ l _) = unsafeFindMin l---- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMax :: Word64Map a -> Maybe (Key, a)-unsafeFindMax Nil = Nothing-unsafeFindMax (Tip ky y) = Just (ky, y)-unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r--{---------------------------------------------------------------------  Disjoint---------------------------------------------------------------------}--- | \(O(n+m)\). Check whether the key sets of two maps are disjoint--- (i.e. their 'intersection' is empty).------ > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True--- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False--- > disjoint (fromList [])        (fromList [])                 == True------ > disjoint a b == null (intersection a b)------ @since 0.6.2.1-disjoint :: Word64Map a -> Word64Map b -> Bool-disjoint Nil _ = True-disjoint _ Nil = True-disjoint (Tip kx _) ys = notMember kx ys-disjoint xs (Tip ky _) = notMember ky xs-disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2 = disjoint1-  | shorter m2 m1 = disjoint2-  | p1 == p2      = disjoint l1 l2 && disjoint r1 r2-  | otherwise     = True-  where-    disjoint1 | nomatch p2 p1 m1 = True-              | zero p2 m1       = disjoint l1 t2-              | otherwise        = disjoint r1 t2-    disjoint2 | nomatch p1 p2 m2 = True-              | zero p1 m2       = disjoint t1 l2-              | otherwise        = disjoint t1 r2--{---------------------------------------------------------------------  Compose---------------------------------------------------------------------}--- | Relate the keys of one map to the values of--- the other, by using the values of the former as keys for lookups--- in the latter.------ Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument------ > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]------ @--- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')--- @------ __Note:__ Prior to v0.6.4, "Data.Word64Map.Strict" exposed a version of--- 'compose' that forced the values of the output 'Word64Map'. This version does--- not force these values.------ @since 0.6.3.1-compose :: Word64Map c -> Word64Map Word64 -> Word64Map c-compose bc !ab-  | null bc = empty-  | otherwise = mapMaybe (bc !?) ab--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | \(O(1)\). The empty map.------ > empty      == fromList []--- > size empty == 0--empty :: Word64Map a-empty-  = Nil-{-# INLINE empty #-}---- | \(O(1)\). A map of one element.------ > singleton 1 'a'        == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: Key -> a -> Word64Map a-singleton k x-  = Tip k x-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insert---------------------------------------------------------------------}--- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value, i.e. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty                         == singleton 5 'x'--insert :: Key -> a -> Word64Map a -> Word64Map a-insert !k x t@(Bin p m l r)-  | nomatch k p m = link k (Tip k x) p t-  | zero k m      = Bin p m (insert k x l) r-  | otherwise     = Bin p m l (insert k x r)-insert k x t@(Tip ky _)-  | k==ky         = Tip k x-  | otherwise     = link k (Tip k x) ky t-insert k x Nil = Tip k x---- right-biased insertion, used by 'union'--- | \(O(\min(n,W))\). Insert with a combining function.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f new_value old_value@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"--insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a-insertWith f k x t-  = insertWithKey (\_ x' y' -> f x' y') k x t---- | \(O(\min(n,W))\). Insert with a combining function.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f key new_value old_value@.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"--insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a-insertWithKey f !k x t@(Bin p m l r)-  | nomatch k p m = link k (Tip k x) p t-  | zero k m      = Bin p m (insertWithKey f k x l) r-  | otherwise     = Bin p m l (insertWithKey f k x r)-insertWithKey f k x t@(Tip ky y)-  | k == ky       = Tip k (f k x y)-  | otherwise     = link k (Tip k x) ky t-insertWithKey _ k x Nil = Tip k x---- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])--insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)-insertLookupWithKey f !k x t@(Bin p m l r)-  | nomatch k p m = (Nothing,link k (Tip k x) p t)-  | zero k m      = let (found,l') = insertLookupWithKey f k x l-                    in (found,Bin p m l' r)-  | otherwise     = let (found,r') = insertLookupWithKey f k x r-                    in (found,Bin p m l r')-insertLookupWithKey f k x t@(Tip ky y)-  | k == ky       = (Just y,Tip k (f k x y))-  | otherwise     = (Nothing,link k (Tip k x) ky t)-insertLookupWithKey _ k x Nil = (Nothing,Tip k x)---{---------------------------------------------------------------------  Deletion---------------------------------------------------------------------}--- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty                         == empty--delete :: Key -> Word64Map a -> Word64Map a-delete !k t@(Bin p m l r)-  | nomatch k p m = t-  | zero k m      = binCheckLeft p m (delete k l) r-  | otherwise     = binCheckRight p m l (delete k r)-delete k t@(Tip ky _)-  | k == ky       = Nil-  | otherwise     = t-delete _k Nil = Nil---- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty                         == empty--adjust ::  (a -> a) -> Key -> Word64Map a -> Word64Map a-adjust f k m-  = adjustWithKey (\_ x -> f x) k m---- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty                         == empty--adjustWithKey ::  (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a-adjustWithKey f !k (Bin p m l r)-  | zero k m      = Bin p m (adjustWithKey f k l) r-  | otherwise     = Bin p m l (adjustWithKey f k r)-adjustWithKey f k t@(Tip ky y)-  | k == ky       = Tip ky (f k y)-  | otherwise     = t-adjustWithKey _ _ Nil = Nil----- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update ::  (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a-update f-  = updateWithKey (\_ x -> f x)---- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a-updateWithKey f !k (Bin p m l r)-  | zero k m      = binCheckLeft p m (updateWithKey f k l) r-  | otherwise     = binCheckRight p m l (updateWithKey f k r)-updateWithKey f k t@(Tip ky y)-  | k == ky       = case (f k y) of-                      Just y' -> Tip ky y'-                      Nothing -> Nil-  | otherwise     = t-updateWithKey _ _ Nil = Nil---- | \(O(\min(n,W))\). Lookup and update.--- The function returns original value, if it is updated.--- This is different behavior than 'Data.Map.updateLookupWithKey'.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")--updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)-updateLookupWithKey f !k (Bin p m l r)-  | zero k m      = let !(found,l') = updateLookupWithKey f k l-                    in (found,binCheckLeft p m l' r)-  | otherwise     = let !(found,r') = updateLookupWithKey f k r-                    in (found,binCheckRight p m l r')-updateLookupWithKey f k t@(Tip ky y)-  | k==ky         = case (f k y) of-                      Just y' -> (Just y,Tip ky y')-                      Nothing -> (Just y,Nil)-  | otherwise     = (Nothing,t)-updateLookupWithKey _ _ Nil = (Nothing,Nil)------ | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.-alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a-alter f !k t@(Bin p m l r)-  | nomatch k p m = case f Nothing of-                      Nothing -> t-                      Just x -> link k (Tip k x) p t-  | zero k m      = binCheckLeft p m (alter f k l) r-  | otherwise     = binCheckRight p m l (alter f k r)-alter f k t@(Tip ky y)-  | k==ky         = case f (Just y) of-                      Just x -> Tip ky x-                      Nothing -> Nil-  | otherwise     = case f Nothing of-                      Just x -> link k (Tip k x) ky t-                      Nothing -> Tip ky y-alter f k Nil     = case f Nothing of-                      Just x -> Tip k x-                      Nothing -> Nil---- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,--- or update a value in an 'Word64Map'.  In short : @'lookup' k <$> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)--- interactiveAlter k m = alterF f k m where---   f Nothing = do---      putStrLn $ show k ++---          " was not found in the map. Would you like to add it?"---      getUserResponse1 :: IO (Maybe String)---   f (Just old) = do---      putStrLn $ "The key is currently bound to " ++ show old ++---          ". Would you like to change or delete it?"---      getUserResponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map.------ Note: 'alterF' is a flipped version of the @at@ combinator from--- @Control.Lens.At@.------ @since 0.5.8--alterF :: Functor f-       => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)--- This implementation was stolen from 'Control.Lens.At'.-alterF f k m = (<$> f mv) $ \fres ->-  case fres of-    Nothing -> maybe m (const (delete k m)) mv-    Just v' -> insert k v' m-  where mv = lookup k m--{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of maps.------ > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "b"), (5, "a"), (7, "C")]--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]--- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]--unions :: Foldable f => f (Word64Map a) -> Word64Map a-unions xs-  = Foldable.foldl' union empty xs---- | The union of a list of maps, with a combining operation.------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a-unionsWith f ts-  = Foldable.foldl' (unionWith f) empty ts---- | \(O(n+m)\). The (left-biased) union of two maps.--- It prefers the first map when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).------ > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]--union :: Word64Map a -> Word64Map a -> Word64Map a-union m1 m2-  = mergeWithKey' Bin const id id m1 m2---- | \(O(n+m)\). The union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a-unionWith f m1 m2-  = unionWithKey (\_ x y -> f x y) m1 m2---- | \(O(n+m)\). The union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a-unionWithKey f m1 m2-  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | \(O(n+m)\). Difference between two maps (based on keys).------ > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"--difference :: Word64Map a -> Word64Map b -> Word64Map a-difference m1 m2-  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2---- | \(O(n+m)\). Difference with a combining function.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- >     == singleton 3 "b:B"--differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a-differenceWith f m1 m2-  = differenceWithKey (\_ x y -> f x y) m1 m2---- | \(O(n+m)\). Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference).--- If it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- >     == singleton 3 "3:b|B"--differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a-differenceWithKey f m1 m2-  = mergeWithKey f id (const Nil) m1 m2----- TODO(wrengr): re-verify that asymptotic bound--- | \(O(n+m)\). Remove all the keys in a given set from a map.------ @--- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.notMember`` s) m--- @------ @since 0.5.8-withoutKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a-withoutKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)-    | shorter m1 m2  = difference1-    | shorter m2 m1  = difference2-    | p1 == p2       = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)-    | otherwise      = t1-    where-    difference1-        | nomatch p2 p1 m1  = t1-        | zero p2 m1        = binCheckLeft p1 m1 (withoutKeys l1 t2) r1-        | otherwise         = binCheckRight p1 m1 l1 (withoutKeys r1 t2)-    difference2-        | nomatch p1 p2 m2  = t1-        | zero p1 m2        = withoutKeys t1 l2-        | otherwise         = withoutKeys t1 r2-withoutKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =-    let minbit = bitmapOf p1-        lt_minbit = minbit - 1-        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))-        gt_maxbit = (-maxbit) `xor` maxbit-    -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'-    -- and 'withoutBM' here, in order to avoid redundant case analyses?-    in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)-withoutKeys t1@(Bin _ _ _ _) Word64Set.Nil = t1-withoutKeys t1@(Tip k1 _) t2-    | k1 `Word64Set.member` t2 = Nil-    | otherwise = t1-withoutKeys Nil _ = Nil---updatePrefix-    :: Word64SetPrefix -> Word64Map a -> (Word64Map a -> Word64Map a) -> Word64Map a-updatePrefix !kp t@(Bin p m l r) f-    | m .&. Word64Set.suffixBitMask /= 0 =-        if p .&. Word64Set.prefixBitMask == kp then f t else t-    | nomatch kp p m = t-    | zero kp m      = binCheckLeft p m (updatePrefix kp l f) r-    | otherwise      = binCheckRight p m l (updatePrefix kp r f)-updatePrefix kp t@(Tip kx _) f-    | kx .&. Word64Set.prefixBitMask == kp = f t-    | otherwise = t-updatePrefix _ Nil _ = Nil---withoutBM :: Word64SetBitMap -> Word64Map a -> Word64Map a-withoutBM 0 t = t-withoutBM bm (Bin p m l r) =-    let leftBits = bitmapOf (p .|. m) - 1-        bmL = bm .&. leftBits-        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)-    in  bin p m (withoutBM bmL l) (withoutBM bmR r)-withoutBM bm t@(Tip k _)-    -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?-    | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = Nil-    | otherwise = t-withoutBM _ Nil = Nil---{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | \(O(n+m)\). The (left-biased) intersection of two maps (based on keys).------ > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"--intersection :: Word64Map a -> Word64Map b -> Word64Map a-intersection m1 m2-  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2----- TODO(wrengr): re-verify that asymptotic bound--- | \(O(n+m)\). The restriction of a map to the keys in a set.------ @--- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.member`` s) m--- @------ @since 0.5.8-restrictKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a-restrictKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)-    | shorter m1 m2  = intersection1-    | shorter m2 m1  = intersection2-    | p1 == p2       = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)-    | otherwise      = Nil-    where-    intersection1-        | nomatch p2 p1 m1  = Nil-        | zero p2 m1        = restrictKeys l1 t2-        | otherwise         = restrictKeys r1 t2-    intersection2-        | nomatch p1 p2 m2  = Nil-        | zero p1 m2        = restrictKeys t1 l2-        | otherwise         = restrictKeys t1 r2-restrictKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =-    let minbit = bitmapOf p1-        ge_minbit = complement (minbit - 1)-        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))-        le_maxbit = maxbit .|. (maxbit - 1)-    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'-    -- and 'restrictBM' here, in order to avoid redundant case analyses?-    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)-restrictKeys (Bin _ _ _ _) Word64Set.Nil = Nil-restrictKeys t1@(Tip k1 _) t2-    | k1 `Word64Set.member` t2 = t1-    | otherwise = Nil-restrictKeys Nil _ = Nil----- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching--- a key prefix.-lookupPrefix :: Word64SetPrefix -> Word64Map a -> Word64Map a-lookupPrefix !kp t@(Bin p m l r)-    | m .&. Word64Set.suffixBitMask /= 0 =-        if p .&. Word64Set.prefixBitMask == kp then t else Nil-    | nomatch kp p m = Nil-    | zero kp m      = lookupPrefix kp l-    | otherwise      = lookupPrefix kp r-lookupPrefix kp t@(Tip kx _)-    | (kx .&. Word64Set.prefixBitMask) == kp = t-    | otherwise = Nil-lookupPrefix _ Nil = Nil---restrictBM :: Word64SetBitMap -> Word64Map a -> Word64Map a-restrictBM 0 _ = Nil-restrictBM bm (Bin p m l r) =-    let leftBits = bitmapOf (p .|. m) - 1-        bmL = bm .&. leftBits-        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)-    in  bin p m (restrictBM bmL l) (restrictBM bmR r)-restrictBM bm t@(Tip k _)-    -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?-    | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = t-    | otherwise = Nil-restrictBM _ Nil = Nil----- | \(O(n+m)\). The intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c-intersectionWith f m1 m2-  = intersectionWithKey (\_ x y -> f x y) m1 m2---- | \(O(n+m)\). The intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c-intersectionWithKey f m1 m2-  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2--{---------------------------------------------------------------------  MergeWithKey---------------------------------------------------------------------}---- | \(O(n+m)\). A high-performance universal combining function. Using--- 'mergeWithKey', all combining functions can be defined without any loss of--- efficiency (with exception of 'union', 'difference' and 'intersection',--- where sharing of some nodes is lost with 'mergeWithKey').------ Please make sure you know what is going on when using 'mergeWithKey',--- otherwise you can be surprised by unexpected code growth or even--- corruption of the data structure.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define your custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'Word64Map's is created, such that------ * if a key is present in both maps, it is passed with both corresponding---   values to the @combine@ function. Depending on the result, the key is either---   present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and---   the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and---   the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily. Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or--- @'filterWithKey' f@ could be used for any @f@.--mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)-             -> Word64Map a -> Word64Map b -> Word64Map c-mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2-  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.-        combine = \(Tip k1 x1) (Tip _k2 x2) ->-          case f k1 x1 x2 of-            Nothing -> Nil-            Just x -> Tip k1 x-        {-# INLINE combine #-}-{-# INLINE mergeWithKey #-}---- Slightly more general version of mergeWithKey. It differs in the following:------ * the combining function operates on maps instead of keys and values. The---   reason is to enable sharing in union, difference and intersection.------ * mergeWithKey' is given an equivalent of bin. The reason is that in union*,---   Bin constructor can be used, because we know both subtrees are nonempty.--mergeWithKey' :: (Prefix -> Mask -> Word64Map c -> Word64Map c -> Word64Map c)-              -> (Word64Map a -> Word64Map b -> Word64Map c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)-              -> Word64Map a -> Word64Map b -> Word64Map c-mergeWithKey' bin' f g1 g2 = go-  where-    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-      | shorter m1 m2  = merge1-      | shorter m2 m1  = merge2-      | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)-      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)-      where-        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)-               | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)-               | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)-        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)-               | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)-               | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)--    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'-      where-        merge0 t2 k2 t1@(Bin p1 m1 l1 r1)-          | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)-          | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)-          | otherwise  = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)-        merge0 t2 k2 t1@(Tip k1 _)-          | k1 == k2 = f t1 t2-          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)-        merge0 t2 _  Nil = g2 t2--    go t1@(Bin _ _ _ _) Nil = g1 t1--    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'-      where-        merge0 t1 k1 t2@(Bin p2 m2 l2 r2)-          | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)-          | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)-          | otherwise  = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)-        merge0 t1 k1 t2@(Tip k2 _)-          | k1 == k2 = f t1 t2-          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)-        merge0 t1 _  Nil = g1 t1--    go Nil t2 = g2 t2--    maybe_link _ Nil _ t2 = t2-    maybe_link _ t1 _ Nil = t1-    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2-    {-# INLINE maybe_link #-}-{-# INLINE mergeWithKey' #-}---{---------------------------------------------------------------------  mergeA---------------------------------------------------------------------}---- | A tactic for dealing with keys present in one map but not the--- other in 'merge' or 'mergeA'.------ A tactic of type @WhenMissing f k x z@ is an abstract representation--- of a function of type @Key -> x -> f (Maybe z)@.------ @since 0.5.9--data WhenMissing f x y = WhenMissing-  { missingSubtree :: Word64Map x -> f (Word64Map y)-  , missingKey :: Key -> x -> f (Maybe y)}---- | @since 0.5.9-instance (Applicative f, Monad f) => Functor (WhenMissing f x) where-  fmap = mapWhenMissing-  {-# INLINE fmap #-}----- | @since 0.5.9-instance (Applicative f, Monad f) => Category.Category (WhenMissing f)-  where-    id = preserveMissing-    f . g =-      traverseMaybeMissing $ \ k x -> do-        y <- missingKey g k x-        case y of-          Nothing -> pure Nothing-          Just q  -> missingKey f k q-    {-# INLINE id #-}-    {-# INLINE (.) #-}----- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.------ @since 0.5.9-instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where-  pure x = mapMissing (\ _ _ -> x)-  f <*> g =-    traverseMaybeMissing $ \k x -> do-      res1 <- missingKey f k x-      case res1 of-        Nothing -> pure Nothing-        Just r  -> (pure $!) . fmap r =<< missingKey g k x-  {-# INLINE pure #-}-  {-# INLINE (<*>) #-}----- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.------ @since 0.5.9-instance (Applicative f, Monad f) => Monad (WhenMissing f x) where-  m >>= f =-    traverseMaybeMissing $ \k x -> do-      res1 <- missingKey m k x-      case res1 of-        Nothing -> pure Nothing-        Just r  -> missingKey (f r) k x-  {-# INLINE (>>=) #-}----- | Map covariantly over a @'WhenMissing' f x@.------ @since 0.5.9-mapWhenMissing-  :: (Applicative f, Monad f)-  => (a -> b)-  -> WhenMissing f x a-  -> WhenMissing f x b-mapWhenMissing f t = WhenMissing-  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'-  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }-{-# INLINE mapWhenMissing #-}----- | Map covariantly over a @'WhenMissing' f x@, using only a--- 'Functor f' constraint.-mapGentlyWhenMissing-  :: Functor f-  => (a -> b)-  -> WhenMissing f x a-  -> WhenMissing f x b-mapGentlyWhenMissing f t = WhenMissing-  { missingSubtree = \m -> fmap f <$> missingSubtree t m-  , missingKey     = \k x -> fmap f <$> missingKey t k x }-{-# INLINE mapGentlyWhenMissing #-}----- | Map covariantly over a @'WhenMatched' f k x@, using only a--- 'Functor f' constraint.-mapGentlyWhenMatched-  :: Functor f-  => (a -> b)-  -> WhenMatched f x y a-  -> WhenMatched f x y b-mapGentlyWhenMatched f t =-  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y-{-# INLINE mapGentlyWhenMatched #-}----- | Map contravariantly over a @'WhenMissing' f _ x@.------ @since 0.5.9-lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x-lmapWhenMissing f t = WhenMissing-  { missingSubtree = \m -> missingSubtree t (fmap f m)-  , missingKey     = \k x -> missingKey t k (f x) }-{-# INLINE lmapWhenMissing #-}----- | Map contravariantly over a @'WhenMatched' f _ y z@.------ @since 0.5.9-contramapFirstWhenMatched-  :: (b -> a)-  -> WhenMatched f a y z-  -> WhenMatched f b y z-contramapFirstWhenMatched f t =-  WhenMatched $ \k x y -> runWhenMatched t k (f x) y-{-# INLINE contramapFirstWhenMatched #-}----- | Map contravariantly over a @'WhenMatched' f x _ z@.------ @since 0.5.9-contramapSecondWhenMatched-  :: (b -> a)-  -> WhenMatched f x a z-  -> WhenMatched f x b z-contramapSecondWhenMatched f t =-  WhenMatched $ \k x y -> runWhenMatched t k x (f y)-{-# INLINE contramapSecondWhenMatched #-}----- | A tactic for dealing with keys present in one map but not the--- other in 'merge'.------ A tactic of type @SimpleWhenMissing x z@ is an abstract--- representation of a function of type @Key -> x -> Maybe z@.------ @since 0.5.9-type SimpleWhenMissing = WhenMissing Identity----- | A tactic for dealing with keys present in both maps in 'merge'--- or 'mergeA'.------ A tactic of type @WhenMatched f x y z@ is an abstract representation--- of a function of type @Key -> x -> y -> f (Maybe z)@.------ @since 0.5.9-newtype WhenMatched f x y z = WhenMatched-  { matchedKey :: Key -> x -> y -> f (Maybe z) }----- | Along with zipWithMaybeAMatched, witnesses the isomorphism--- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.------ @since 0.5.9-runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)-runWhenMatched = matchedKey-{-# INLINE runWhenMatched #-}----- | Along with traverseMaybeMissing, witnesses the isomorphism--- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.------ @since 0.5.9-runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)-runWhenMissing = missingKey-{-# INLINE runWhenMissing #-}----- | @since 0.5.9-instance Functor f => Functor (WhenMatched f x y) where-  fmap = mapWhenMatched-  {-# INLINE fmap #-}----- | @since 0.5.9-instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)-  where-    id = zipWithMatched (\_ _ y -> y)-    f . g =-      zipWithMaybeAMatched $ \k x y -> do-        res <- runWhenMatched g k x y-        case res of-          Nothing -> pure Nothing-          Just r  -> runWhenMatched f k x r-    {-# INLINE id #-}-    {-# INLINE (.) #-}----- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@------ @since 0.5.9-instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where-  pure x = zipWithMatched (\_ _ _ -> x)-  fs <*> xs =-    zipWithMaybeAMatched $ \k x y -> do-      res <- runWhenMatched fs k x y-      case res of-        Nothing -> pure Nothing-        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y-  {-# INLINE pure #-}-  {-# INLINE (<*>) #-}----- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@------ @since 0.5.9-instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where-  m >>= f =-    zipWithMaybeAMatched $ \k x y -> do-      res <- runWhenMatched m k x y-      case res of-        Nothing -> pure Nothing-        Just r  -> runWhenMatched (f r) k x y-  {-# INLINE (>>=) #-}----- | Map covariantly over a @'WhenMatched' f x y@.------ @since 0.5.9-mapWhenMatched-  :: Functor f-  => (a -> b)-  -> WhenMatched f x y a-  -> WhenMatched f x y b-mapWhenMatched f (WhenMatched g) =-  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)-{-# INLINE mapWhenMatched #-}----- | A tactic for dealing with keys present in both maps in 'merge'.------ A tactic of type @SimpleWhenMatched x y z@ is an abstract--- representation of a function of type @Key -> x -> y -> Maybe z@.------ @since 0.5.9-type SimpleWhenMatched = WhenMatched Identity----- | When a key is found in both maps, apply a function to the key--- and values and use the result in the merged map.------ > zipWithMatched--- >   :: (Key -> x -> y -> z)--- >   -> SimpleWhenMatched x y z------ @since 0.5.9-zipWithMatched-  :: Applicative f-  => (Key -> x -> y -> z)-  -> WhenMatched f x y z-zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y-{-# INLINE zipWithMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values to produce an action and use its result in the merged--- map.------ @since 0.5.9-zipWithAMatched-  :: Applicative f-  => (Key -> x -> y -> f z)-  -> WhenMatched f x y z-zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y-{-# INLINE zipWithAMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values and maybe use the result in the merged map.------ > zipWithMaybeMatched--- >   :: (Key -> x -> y -> Maybe z)--- >   -> SimpleWhenMatched x y z------ @since 0.5.9-zipWithMaybeMatched-  :: Applicative f-  => (Key -> x -> y -> Maybe z)-  -> WhenMatched f x y z-zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y-{-# INLINE zipWithMaybeMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values, perform the resulting action, and maybe use the--- result in the merged map.------ This is the fundamental 'WhenMatched' tactic.------ @since 0.5.9-zipWithMaybeAMatched-  :: (Key -> x -> y -> f (Maybe z))-  -> WhenMatched f x y z-zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y-{-# INLINE zipWithMaybeAMatched #-}----- | Drop all the entries whose keys are missing from the other--- map.------ > dropMissing :: SimpleWhenMissing x y------ prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)------ but @dropMissing@ is much faster.------ @since 0.5.9-dropMissing :: Applicative f => WhenMissing f x y-dropMissing = WhenMissing-  { missingSubtree = const (pure Nil)-  , missingKey     = \_ _ -> pure Nothing }-{-# INLINE dropMissing #-}----- | Preserve, unchanged, the entries whose keys are missing from--- the other map.------ > preserveMissing :: SimpleWhenMissing x x------ prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)------ but @preserveMissing@ is much faster.------ @since 0.5.9-preserveMissing :: Applicative f => WhenMissing f x x-preserveMissing = WhenMissing-  { missingSubtree = pure-  , missingKey     = \_ v -> pure (Just v) }-{-# INLINE preserveMissing #-}----- | Map over the entries whose keys are missing from the other map.------ > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y------ prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)------ but @mapMissing@ is somewhat faster.------ @since 0.5.9-mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y-mapMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapWithKey f m-  , missingKey     = \k x -> pure $ Just (f k x) }-{-# INLINE mapMissing #-}----- | Map over the entries whose keys are missing from the other--- map, optionally removing some. This is the most powerful--- 'SimpleWhenMissing' tactic, but others are usually more efficient.------ > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y------ prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))------ but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'--- operations.------ @since 0.5.9-mapMaybeMissing-  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y-mapMaybeMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapMaybeWithKey f m-  , missingKey     = \k x -> pure $! f k x }-{-# INLINE mapMaybeMissing #-}----- | Filter the entries whose keys are missing from the other map.------ > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x------ prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x------ but this should be a little faster.------ @since 0.5.9-filterMissing-  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x-filterMissing f = WhenMissing-  { missingSubtree = \m -> pure $! filterWithKey f m-  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }-{-# INLINE filterMissing #-}----- | Filter the entries whose keys are missing from the other map--- using some 'Applicative' action.------ > filterAMissing f = Merge.Lazy.traverseMaybeMissing $--- >   \k x -> (\b -> guard b *> Just x) <$> f k x------ but this should be a little faster.------ @since 0.5.9-filterAMissing-  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x-filterAMissing f = WhenMissing-  { missingSubtree = \m -> filterWithKeyA f m-  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }-{-# INLINE filterAMissing #-}----- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.-filterWithKeyA-  :: Applicative f => (Key -> a -> f Bool) -> Word64Map a -> f (Word64Map a)-filterWithKeyA _ Nil           = pure Nil-filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x-filterWithKeyA f (Bin p m l r)-  | m < 0     = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)-  | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)---- | This wasn't in Data.Bool until 4.7.0, so we define it here-bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True  = t----- | Traverse over the entries whose keys are missing from the other--- map.------ @since 0.5.9-traverseMissing-  :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y-traverseMissing f = WhenMissing-  { missingSubtree = traverseWithKey f-  , missingKey = \k x -> Just <$> f k x }-{-# INLINE traverseMissing #-}----- | Traverse over the entries whose keys are missing from the other--- map, optionally producing values to put in the result. This is--- the most powerful 'WhenMissing' tactic, but others are usually--- more efficient.------ @since 0.5.9-traverseMaybeMissing-  :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y-traverseMaybeMissing f = WhenMissing-  { missingSubtree = traverseMaybeWithKey f-  , missingKey = f }-{-# INLINE traverseMaybeMissing #-}----- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.------ @since 0.6.4-traverseMaybeWithKey-  :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)-traverseMaybeWithKey f = go-    where-    go Nil           = pure Nil-    go (Tip k x)     = maybe Nil (Tip k) <$> f k x-    go (Bin p m l r)-      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)-      | otherwise = liftA2 (bin p m) (go l) (go r)----- | Merge two maps.------ 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic--- and two maps. It uses the tactics to merge the maps. Its behavior--- is best understood via its fundamental tactics, 'mapMaybeMissing'--- and 'zipWithMaybeMatched'.------ Consider------ @--- merge (mapMaybeMissing g1)---              (mapMaybeMissing g2)---              (zipWithMaybeMatched f)---              m1 m2--- @------ Take, for example,------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ 'merge' will first \"align\" these maps by key:------ @--- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]--- m2 =           [(1, "one"), (2, "two"),           (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]--- @------ This produces a 'Maybe' for each key:------ @--- keys =     0        1          2           3        4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'mapMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.------ When 'merge' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should typically use--- 'merge' to define your custom combining functions.--------- Examples:------ prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)--- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)--- prop> differenceWith f = merge diffPreserve diffDrop f--- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)--- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)------ @since 0.5.9-merge-  :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@-  -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@-  -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@-  -> Word64Map a -- ^ Map @m1@-  -> Word64Map b -- ^ Map @m2@-  -> Word64Map c-merge g1 g2 f m1 m2 =-  runIdentity $ mergeA g1 g2 f m1 m2-{-# INLINE merge #-}----- | An applicative version of 'merge'.------ 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'--- tactic and two maps. It uses the tactics to merge the maps.--- Its behavior is best understood via its fundamental tactics,--- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.------ Consider------ @--- mergeA (traverseMaybeMissing g1)---               (traverseMaybeMissing g2)---               (zipWithMaybeAMatched f)---               m1 m2--- @------ Take, for example,------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ 'mergeA' will first \"align\" these maps by key:------ @--- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]--- m2 =           [(1, "one"), (2, "two"),           (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]--- @------ Next, it will perform the actions in the @actions@ list in order from--- left to right.------ @--- keys =     0        1          2           3        4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'traverseMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.--- * 'mapMaybeMissing' does not use the 'Applicative' context.------ When 'mergeA' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should generally only use--- 'mergeA' to define custom combining functions.------ @since 0.5.9-mergeA-  :: (Applicative f)-  => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@-  -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@-  -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@-  -> Word64Map a -- ^ Map @m1@-  -> Word64Map b -- ^ Map @m2@-  -> f (Word64Map c)-mergeA-    WhenMissing{missingSubtree = g1t, missingKey = g1k}-    WhenMissing{missingSubtree = g2t, missingKey = g2k}-    WhenMatched{matchedKey = f}-    = go-  where-    go t1  Nil = g1t t1-    go Nil t2  = g2t t2--    -- This case is already covered below.-    -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2--    go (Tip k1 x1) t2' = merge2 t2'-      where-        merge2 t2@(Bin p2 m2 l2 r2)-          | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)-          | zero k1 m2       = binA p2 m2 (merge2 l2) (g2t r2)-          | otherwise        = binA p2 m2 (g2t l2) (merge2 r2)-        merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2-        merge2 Nil           = subsingletonBy g1k k1 x1--    go t1' (Tip k2 x2) = merge1 t1'-      where-        merge1 t1@(Bin p1 m1 l1 r1)-          | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)-          | zero k2 m1       = binA p1 m1 (merge1 l1) (g1t r1)-          | otherwise        = binA p1 m1 (g1t l1) (merge1 r1)-        merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2-        merge1 Nil           = subsingletonBy g2k k2 x2--    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-      | shorter m1 m2  = merge1-      | shorter m2 m1  = merge2-      | p1 == p2       = binA p1 m1 (go l1 l2) (go r1 r2)-      | otherwise      = linkA p1 (g1t t1) p2 (g2t t2)-      where-        merge1 | nomatch p2 p1 m1  = linkA p1 (g1t t1) p2 (g2t t2)-               | zero p2 m1        = binA p1 m1 (go  l1 t2) (g1t r1)-               | otherwise         = binA p1 m1 (g1t l1)    (go  r1 t2)-        merge2 | nomatch p1 p2 m2  = linkA p1 (g1t t1) p2 (g2t t2)-               | zero p1 m2        = binA p2 m2 (go  t1 l2) (g2t    r2)-               | otherwise         = binA p2 m2 (g2t    l2) (go  t1 r2)--    subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x-    {-# INLINE subsingletonBy #-}--    mergeTips k1 x1 k2 x2-      | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2-      | k1 <  k2  = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)-        {--        = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2-        -}-      | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)-    {-# INLINE mergeTips #-}--    subdoubleton _ _   Nothing Nothing     = Nil-    subdoubleton _ k2  Nothing (Just y2)   = Tip k2 y2-    subdoubleton k1 _  (Just y1) Nothing   = Tip k1 y1-    subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)-    {-# INLINE subdoubleton #-}--    -- A variant of 'link_' which makes sure to execute side-effects-    -- in the right order.-    linkA-        :: Applicative f-        => Prefix -> f (Word64Map a)-        -> Prefix -> f (Word64Map a)-        -> f (Word64Map a)-    linkA p1 t1 p2 t2-      | zero p1 m = binA p m t1 t2-      | otherwise = binA p m t2 t1-      where-        m = branchMask p1 p2-        p = mask p1 m-    {-# INLINE linkA #-}--    -- A variant of 'bin' that ensures that effects for negative keys are executed-    -- first.-    binA-        :: Applicative f-        => Prefix-        -> Mask-        -> f (Word64Map a)-        -> f (Word64Map a)-        -> f (Word64Map a)-    binA p m a b-      | m < 0     = liftA2 (flip (bin p m)) b a-      | otherwise = liftA2       (bin p m)  a b-    {-# INLINE binA #-}-{-# INLINE mergeA #-}---{---------------------------------------------------------------------  Min\/Max---------------------------------------------------------------------}---- | \(O(\min(n,W))\). Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a-updateMinWithKey f t =-  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)-            _ -> go f t-  where-    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r-    go f' (Tip k y) = case f' k y of-                        Just y' -> Tip k y'-                        Nothing -> Nil-    go _ Nil = error "updateMinWithKey Nil"---- | \(O(\min(n,W))\). Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a-updateMaxWithKey f t =-  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r-            _ -> go f t-  where-    go f' (Bin p m l r) = binCheckRight p m l (go f' r)-    go f' (Tip k y) = case f' k y of-                        Just y' -> Tip k y'-                        Nothing -> Nil-    go _ Nil = error "updateMaxWithKey Nil"---data View a = View {-# UNPACK #-} !Key a !(Word64Map a)---- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")--- > maxViewWithKey empty == Nothing--maxViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)-maxViewWithKey t = case t of-  Nil -> Nothing-  _ -> Just $ case maxViewWithKeySure t of-                View k v t' -> ((k, v), t')-{-# INLINE maxViewWithKey #-}--maxViewWithKeySure :: Word64Map a -> View a-maxViewWithKeySure t =-  case t of-    Nil -> error "maxViewWithKeySure Nil"-    Bin p m l r | m < 0 ->-      case go l of View k a l' -> View k a (binCheckLeft p m l' r)-    _ -> go t-  where-    go (Bin p m l r) =-        case go r of View k a r' -> View k a (binCheckRight p m l r')-    go (Tip k y) = View k y Nil-    go Nil = error "maxViewWithKey_go Nil"--- See note on NOINLINE at minViewWithKeySure-{-# NOINLINE maxViewWithKeySure #-}---- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing--minViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)-minViewWithKey t =-  case t of-    Nil -> Nothing-    _ -> Just $ case minViewWithKeySure t of-                  View k v t' -> ((k, v), t')--- We inline this to give GHC the best possible chance of--- getting rid of the Maybe, pair, and Int constructors, as--- well as a thunk under the Just. That is, we really want to--- be certain this inlines!-{-# INLINE minViewWithKey #-}--minViewWithKeySure :: Word64Map a -> View a-minViewWithKeySure t =-  case t of-    Nil -> error "minViewWithKeySure Nil"-    Bin p m l r | m < 0 ->-      case go r of-        View k a r' -> View k a (binCheckRight p m l r')-    _ -> go t-  where-    go (Bin p m l r) =-        case go l of View k a l' -> View k a (binCheckLeft p m l' r)-    go (Tip k y) = View k y Nil-    go Nil = error "minViewWithKey_go Nil"--- There's never anything significant to be gained by inlining--- this. Sufficiently recent GHC versions will inline the wrapper--- anyway, which should be good enough.-{-# NOINLINE minViewWithKeySure #-}---- | \(O(\min(n,W))\). Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a-updateMax f = updateMaxWithKey (const f)---- | \(O(\min(n,W))\). Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a-updateMin f = updateMinWithKey (const f)---- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map--- stripped of that element, or 'Nothing' if passed an empty map.-maxView :: Word64Map a -> Maybe (a, Word64Map a)-maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)---- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map--- stripped of that element, or 'Nothing' if passed an empty map.-minView :: Word64Map a -> Maybe (a, Word64Map a)-minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)---- | \(O(\min(n,W))\). Delete and find the maximal element.--- This function throws an error if the map is empty. Use 'maxViewWithKey'--- if the map may be empty.-deleteFindMax :: Word64Map a -> ((Key, a), Word64Map a)-deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey---- | \(O(\min(n,W))\). Delete and find the minimal element.--- This function throws an error if the map is empty. Use 'minViewWithKey'--- if the map may be empty.-deleteFindMin :: Word64Map a -> ((Key, a), Word64Map a)-deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey---- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.-lookupMin :: Word64Map a -> Maybe (Key, a)-lookupMin Nil = Nothing-lookupMin (Tip k v) = Just (k,v)-lookupMin (Bin _ m l r)-  | m < 0     = go r-  | otherwise = go l-    where go (Tip k v)      = Just (k,v)-          go (Bin _ _ l' _) = go l'-          go Nil            = Nothing---- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.--- Use 'minViewWithKey' if the map may be empty.-findMin :: Word64Map a -> (Key, a)-findMin t-  | Just r <- lookupMin t = r-  | otherwise = error "findMin: empty map has no minimal element"---- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.-lookupMax :: Word64Map a -> Maybe (Key, a)-lookupMax Nil = Nothing-lookupMax (Tip k v) = Just (k,v)-lookupMax (Bin _ m l r)-  | m < 0     = go l-  | otherwise = go r-    where go (Tip k v)      = Just (k,v)-          go (Bin _ _ _ r') = go r'-          go Nil            = Nothing---- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.--- Use 'maxViewWithKey' if the map may be empty.-findMax :: Word64Map a -> (Key, a)-findMax t-  | Just r <- lookupMax t = r-  | otherwise = error "findMax: empty map has no maximal element"---- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.------ Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;--- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.-deleteMin :: Word64Map a -> Word64Map a-deleteMin = maybe Nil snd . minView---- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty.------ Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;--- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.-deleteMax :: Word64Map a -> Word64Map a-deleteMax = maybe Nil snd . maxView---{---------------------------------------------------------------------  Submap---------------------------------------------------------------------}--- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).-isProperSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool-isProperSubmapOf m1 m2-  = isProperSubmapOfBy (==) m1 m2--{- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when- @keys m1@ and @keys m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':--  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':--  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])-  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])--}-isProperSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool-isProperSubmapOfBy predicate t1 t2-  = case submapCmp predicate t1 t2 of-      LT -> True-      _  -> False--submapCmp :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Ordering-submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = GT-  | shorter m2 m1  = submapCmpLt-  | p1 == p2       = submapCmpEq-  | otherwise      = GT  -- disjoint-  where-    submapCmpLt | nomatch p1 p2 m2  = GT-                | zero p1 m2        = submapCmp predicate t1 l2-                | otherwise         = submapCmp predicate t1 r2-    submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of-                    (GT,_ ) -> GT-                    (_ ,GT) -> GT-                    (EQ,EQ) -> EQ-                    _       -> LT--submapCmp _         (Bin _ _ _ _) _  = GT-submapCmp predicate (Tip kx x) (Tip ky y)-  | (kx == ky) && predicate x y = EQ-  | otherwise                   = GT  -- disjoint-submapCmp predicate (Tip k x) t-  = case lookup k t of-     Just y | predicate x y -> LT-     _                      -> GT -- disjoint-submapCmp _    Nil Nil = EQ-submapCmp _    Nil _   = LT---- | \(O(n+m)\). Is this a submap?--- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).-isSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool-isSubmapOf m1 m2-  = isSubmapOfBy (==) m1 m2--{- | \(O(n+m)\).- The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':--  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':--  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])--}-isSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool-isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = False-  | shorter m2 m1  = match p1 p2 m2 &&-                       if zero p1 m2-                       then isSubmapOfBy predicate t1 l2-                       else isSubmapOfBy predicate t1 r2-  | otherwise      = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2-isSubmapOfBy _         (Bin _ _ _ _) _ = False-isSubmapOfBy predicate (Tip k x) t     = case lookup k t of-                                         Just y  -> predicate x y-                                         Nothing -> False-isSubmapOfBy _         Nil _           = True--{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | \(O(n)\). Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> Word64Map a -> Word64Map b-map f = go-  where-    go (Bin p m l r) = Bin p m (go l) (go r)-    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.------ > let f key x = (show key) ++ ":" ++ x--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]--mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b-mapWithKey f t-  = case t of-      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)-      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) =-  mapWithKey (\k a -> f k (g k a)) xs-"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =-  mapWithKey (\k a -> f k (g a)) xs-"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)@--- That is, behaves exactly like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing-traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)-traverseWithKey f = go-  where-    go Nil = pure Nil-    go (Tip k v) = Tip k <$> f k v-    go (Bin p m l r)-      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)-      | otherwise = liftA2 (Bin p m) (go l) (go r)-{-# INLINE traverseWithKey #-}---- | \(O(n)\). The function @'mapAccum'@ threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)---- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccumWithKey f a t-  = mapAccumL f a t---- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating--- argument through the map in ascending order of keys.-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccumL f a t-  = case t of-      Bin p m l r-        | m < 0 ->-            let (a1,r') = mapAccumL f a r-                (a2,l') = mapAccumL f a1 l-            in (a2,Bin p m l' r')-        | otherwise  ->-            let (a1,l') = mapAccumL f a l-                (a2,r') = mapAccumL f a1 r-            in (a2,Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')-      Nil         -> (a,Nil)---- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccumRWithKey f a t-  = case t of-      Bin p m l r-        | m < 0 ->-            let (a1,l') = mapAccumRWithKey f a l-                (a2,r') = mapAccumRWithKey f a1 r-            in (a2,Bin p m l' r')-        | otherwise  ->-            let (a1,r') = mapAccumRWithKey f a r-                (a2,l') = mapAccumRWithKey f a1 l-            in (a2,Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')-      Nil         -> (a,Nil)---- | \(O(n \min(n,W))\).--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the value at the greatest of the--- original keys is retained.------ > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"--mapKeys :: (Key->Key) -> Word64Map a -> Word64Map a-mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []---- | \(O(n \min(n,W))\).--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a-mapKeysWith c f-  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []---- | \(O(n \min(n,W))\).--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- >                     ==> mapKeysMonotonic f s == mapKeys f s--- >     where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has slightly better performance than 'mapKeys'.------ > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]--mapKeysMonotonic :: (Key->Key) -> Word64Map a -> Word64Map a-mapKeysMonotonic f-  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []--{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | \(O(n)\). Filter all values that satisfy some predicate.------ > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty--filter :: (a -> Bool) -> Word64Map a -> Word64Map a-filter p m-  = filterWithKey (\_ x -> p x) m---- | \(O(n)\). Filter all keys\/values that satisfy some predicate.------ > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--filterWithKey :: (Key -> a -> Bool) -> Word64Map a -> Word64Map a-filterWithKey predicate = go-    where-    go Nil           = Nil-    go t@(Tip k x)   = if predicate k x then t else Nil-    go (Bin p m l r) = bin p m (go l) (go r)---- | \(O(n)\). Partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partition :: (a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)-partition p m-  = partitionWithKey (\_ x -> p x) m---- | \(O(n)\). Partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partitionWithKey :: (Key -> a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)-partitionWithKey predicate0 t0 = toPair $ go predicate0 t0-  where-    go predicate t =-      case t of-        Bin p m l r ->-          let (l1 :*: l2) = go predicate l-              (r1 :*: r2) = go predicate r-          in bin p m l1 r1 :*: bin p m l2 r2-        Tip k x-          | predicate k x -> (t :*: Nil)-          | otherwise     -> (Nil :*: t)-        Nil -> (Nil :*: Nil)---- | \(O(\min(n,W))\). Take while a predicate on the keys holds.--- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.--- See note at 'spanAntitone'.------ @--- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'--- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)--- @------ @since 0.6.7-takeWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a-takeWhileAntitone predicate t =-  case t of-    Bin p m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then bin p m (go predicate l) r-        else go predicate r-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = bin p m l (go predicate' r)-      | otherwise         = go predicate' l-    go predicate' t'@(Tip ky _)-      | predicate' ky = t'-      | otherwise     = Nil-    go _ Nil = Nil---- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.--- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.--- See note at 'spanAntitone'.------ @--- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'--- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))--- @------ @since 0.6.7-dropWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a-dropWhileAntitone predicate t =-  case t of-    Bin p m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then go predicate l-        else bin p m l (go predicate r)-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = go predicate' r-      | otherwise         = bin p m (go predicate' l) r-    go predicate' t'@(Tip ky _)-      | predicate' ky = Nil-      | otherwise     = t'-    go _ Nil = Nil---- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.--- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.------ @--- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)--- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs--- @------ Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map--- at some /unspecified/ point.------ @since 0.6.7-spanAntitone :: (Key -> Bool) -> Word64Map a -> (Word64Map a, Word64Map a)-spanAntitone predicate t =-  case t of-    Bin p m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then-          case go predicate l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go predicate r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go predicate t of-          (lt :*: gt) -> (lt, gt)-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt-      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r-    go predicate' t'@(Tip ky _)-      | predicate' ky = (t' :*: Nil)-      | otherwise     = (Nil :*: t')-    go _ Nil = (Nil :*: Nil)---- | \(O(n)\). Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | \(O(n)\). Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b-mapMaybeWithKey f (Bin p m l r)-  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)-mapMaybeWithKey f (Tip k x) = case f k x of-  Just y  -> Tip k y-  Nothing -> Nil-mapMaybeWithKey _ Nil = Nil---- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)-mapEither f m-  = mapEitherWithKey (\_ x -> f x) m---- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0-  where-    go f (Bin p m l r) =-      bin p m l1 r1 :*: bin p m l2 r2-      where-        (l1 :*: l2) = go f l-        (r1 :*: r2) = go f r-    go f (Tip k x) = case f k x of-      Left y  -> (Tip k y :*: Nil)-      Right z -> (Nil :*: Tip k z)-    go _ Nil = (Nil :*: Nil)---- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@--- where all keys in @map1@ are lower than @k@ and all keys in--- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)--split :: Key -> Word64Map a -> (Word64Map a, Word64Map a)-split k t =-  case t of-    Bin p m l r-      | m < 0 ->-        if k >= 0 -- handle negative numbers.-        then-          case go k l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go k r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go k t of-          (lt :*: gt) -> (lt, gt)-  where-    go k' t'@(Bin p m l r)-      | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'-      | zero k' m = case go k' l of (lt :*: gt) -> lt :*: bin p m gt r-      | otherwise = case go k' r of (lt :*: gt) -> bin p m l lt :*: gt-    go k' t'@(Tip ky _)-      | k' > ky   = (t' :*: Nil)-      | k' < ky   = (Nil :*: t')-      | otherwise = (Nil :*: Nil)-    go _ Nil = (Nil :*: Nil)---data SplitLookup a = SplitLookup !(Word64Map a) !(Maybe a) !(Word64Map a)--mapLT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a-mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt-{-# INLINE mapLT #-}--mapGT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a-mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)-{-# INLINE mapGT #-}---- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot--- key was found in the original map.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)--- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)--splitLookup :: Key -> Word64Map a -> (Word64Map a, Maybe a, Word64Map a)-splitLookup k t =-  case-    case t of-      Bin p m l r-        | m < 0 ->-          if k >= 0 -- handle negative numbers.-          then mapLT (flip (bin p m) r) (go k l)-          else mapGT (bin p m l) (go k r)-      _ -> go k t-  of SplitLookup lt fnd gt -> (lt, fnd, gt)-  where-    go k' t'@(Bin p m l r)-      | nomatch k' p m =-          if k' > p-          then SplitLookup t' Nothing Nil-          else SplitLookup Nil Nothing t'-      | zero k' m = mapGT (flip (bin p m) r) (go k' l)-      | otherwise = mapLT (bin p m l) (go k' r)-    go k' t'@(Tip ky y)-      | k' > ky   = SplitLookup t'  Nothing  Nil-      | k' < ky   = SplitLookup Nil Nothing  t'-      | otherwise = SplitLookup Nil (Just y) Nil-    go _ Nil      = SplitLookup Nil Nothing  Nil--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | \(O(n)\). Fold the values in the map using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.------ For example,------ > elems map = foldr (:) [] map------ > let f a len = len + (length a)--- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldr :: (a -> b -> b) -> b -> Word64Map a -> b-foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip _ x)     = f x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr #-}---- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> Word64Map a -> b-foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip _ x)     = f x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr' #-}---- | \(O(n)\). Fold the values in the map using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.------ For example,------ > elems = reverse . foldl (flip (:)) []------ > let f len a = len + (length a)--- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldl :: (a -> b -> a) -> a -> Word64Map b -> a-foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip _ x)     = f z' x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl #-}---- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> Word64Map b -> a-foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip _ x)     = f z' x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl' #-}---- | \(O(n)\). Fold the keys and values in the map using the given right-associative--- binary operator, such that--- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.------ For example,------ > keys map = foldrWithKey (\k x ks -> k:ks) [] map------ > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"-foldrWithKey :: (Key -> a -> b -> b) -> b -> Word64Map a -> b-foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx x)    = f kx x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldrWithKey #-}---- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldrWithKey' :: (Key -> a -> b -> b) -> b -> Word64Map a -> b-foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip kx x)    = f kx x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldrWithKey' #-}---- | \(O(n)\). Fold the keys and values in the map using the given left-associative--- binary operator, such that--- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.------ For example,------ > keys = reverse . foldlWithKey (\ks k x -> k:ks) []------ > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"-foldlWithKey :: (a -> Key -> b -> a) -> a -> Word64Map b -> a-foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx x)    = f z' kx x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldlWithKey #-}---- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldlWithKey' :: (a -> Key -> b -> a) -> a -> Word64Map b -> a-foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip kx x)    = f z' kx x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldlWithKey' #-}---- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that------ @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@------ This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.------ @since 0.5.4-foldMapWithKey :: Monoid m => (Key -> a -> m) -> Word64Map a -> m-foldMapWithKey f = go-  where-    go Nil           = mempty-    go (Tip kx x)    = f kx x-    go (Bin _ m l r)-      | m < 0     = go r `mappend` go l-      | otherwise = go l `mappend` go r-{-# INLINE foldMapWithKey #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | \(O(n)\).--- Return all elements of the map in the ascending order of their keys.--- Subject to list fusion.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []--elems :: Word64Map a -> [a]-elems = foldr (:) []---- | \(O(n)\). Return all keys of the map in ascending order. Subject to list--- fusion.------ > keys (fromList [(5,"a"), (3,"b")]) == [3,5]--- > keys empty == []--keys  :: Word64Map a -> [Key]-keys = foldrWithKey (\k _ ks -> k : ks) []---- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the--- map in ascending key order. Subject to list fusion.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []--assocs :: Word64Map a -> [(Key,a)]-assocs = toAscList---- | \(O(n \min(n,W))\). The set of all keys of the map.------ > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Word64Set.fromList [3,5]--- > keysSet empty == Data.Word64Set.empty--keysSet :: Word64Map a -> Word64Set.Word64Set-keysSet Nil = Word64Set.Nil-keysSet (Tip kx _) = Word64Set.singleton kx-keysSet (Bin p m l r)-  | m .&. Word64Set.suffixBitMask == 0 = Word64Set.Bin p m (keysSet l) (keysSet r)-  | otherwise = Word64Set.Tip (p .&. Word64Set.prefixBitMask) (computeBm (computeBm 0 l) r)-  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'-        computeBm acc (Tip kx _) = acc .|. Word64Set.bitmapOf kx-        computeBm _   Nil = error "Data.Word64Set.keysSet: Nil"---- | \(O(n)\). Build a map from a set of keys and a function which for each key--- computes its value.------ > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.Word64Set.empty == empty--fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a-fromSet _ Word64Set.Nil = Nil-fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)-fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)-  where-    -- This is slightly complicated, as we to convert the dense-    -- representation of Word64Set into tree representation of Word64Map.-    ---    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with-    -- prefix 'prefix'. We split bmask into halves corresponding-    -- to left and right subtree. If they are both nonempty, we-    -- create a Bin node, otherwise exactly one of them is nonempty-    -- and we construct the Word64Map from that half.-    buildTree g !prefix !bmask bits = case bits of-      0 -> Tip prefix (g prefix)-      _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of-        bits2-          | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->-              buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2-          | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->-              buildTree g prefix bmask bits2-          | otherwise ->-              Bin prefix bits2-                (buildTree g prefix bmask bits2)-                (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)--{---------------------------------------------------------------------  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.------ > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > toList empty == []--toList :: Word64Map a -> [(Key,a)]-toList = toAscList---- | \(O(n)\). Convert the map to a list of key\/value pairs where the--- keys are in ascending order. Subject to list fusion.------ > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--toAscList :: Word64Map a -> [(Key,a)]-toAscList = foldrWithKey (\k x xs -> (k,x):xs) []---- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys--- are in descending order. Subject to list fusion.------ > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]--toDescList :: Word64Map a -> [(Key,a)]-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-foldrFB = foldrWithKey-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> Key -> b -> a) -> a -> Word64Map b -> a-foldlFB = foldlWithKey-{-# INLINE[0] foldlFB #-}---- Inline assocs and toList, so that we need to fuse only toAscList.-{-# INLINE assocs #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to--- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were--- used in a list fusion, otherwise it would go away in phase 1), and let compiler--- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to--- inline it before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] elems #-}-{-# NOINLINE[0] keys #-}-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "Word64Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}-{-# RULES "Word64Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}-{-# RULES "Word64Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}-{-# RULES "Word64Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}-{-# RULES "Word64Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}-{-# 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.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]--fromList :: [(Key,a)] -> Word64Map a-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x)  = insert k x t---- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]--- > fromListWith (++) [] == empty--fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a-fromListWith f xs-  = fromListWithKey (\_ x y -> f x y) xs---- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.------ > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]--- > fromListWithKey f [] == empty--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order.------ > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--fromAscList :: [(Key,a)] -> Word64Map a-fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)-{-# NOINLINE fromAscList #-}---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a-fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)-{-# NOINLINE fromAscListWith #-}---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a-fromAscListWithKey f = fromMonoListWithKey Nondistinct f-{-# NOINLINE fromAscListWithKey #-}---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order and all distinct.--- /The precondition (input list is strictly ascending) is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--fromDistinctAscList :: [(Key,a)] -> Word64Map a-fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)-{-# NOINLINE fromDistinctAscList #-}---- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys--- and a combining function.------ The precise conditions under which this function works are subtle:--- For any branch mask, keys with the same prefix w.r.t. the branch--- mask must occur consecutively in the list.--fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a-fromMonoListWithKey distinct f = go-  where-    go []              = Nil-    go ((kx,vx) : zs1) = addAll' kx vx zs1--    -- `addAll'` collects all keys equal to `kx` into a single value,-    -- and then proceeds with `addAll`.-    addAll' !kx vx []-        = Tip kx vx-    addAll' !kx vx ((ky,vy) : zs)-        | Nondistinct <- distinct, kx == ky-        = let v = f kx vy vx in addAll' ky v zs-        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)-        | m <- branchMask kx ky-        , Inserted ty zs' <- addMany' m ky vy zs-        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs'--    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`-    -- `addAll` consumes the rest of the list, adding to the tree `tx`-    addAll !_kx !tx []-        = tx-    addAll !kx !tx ((ky,vy) : zs)-        | m <- branchMask kx ky-        , Inserted ty zs' <- addMany' m ky vy zs-        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'--    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.-    addMany' !_m !kx vx []-        = Inserted (Tip kx vx) []-    addMany' !m !kx vx zs0@((ky,vy) : zs)-        | Nondistinct <- distinct, kx == ky-        = let v = f kx vy vx in addMany' m ky v zs-        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)-        | mask kx m /= mask ky m-        = Inserted (Tip kx vx) zs0-        | mxy <- branchMask kx ky-        , Inserted ty zs' <- addMany' mxy ky vy zs-        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs'--    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.-    addMany !_m !_kx tx []-        = Inserted tx []-    addMany !m !kx tx zs0@((ky,vy) : zs)-        | mask kx m /= mask ky m-        = Inserted tx zs0-        | mxy <- branchMask kx ky-        , Inserted ty zs' <- addMany' mxy ky vy zs-        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'-{-# INLINE fromMonoListWithKey #-}--data Inserted a = Inserted !(Word64Map a) ![(Key,a)]--data Distinct = Distinct | Nondistinct--{---------------------------------------------------------------------  Eq---------------------------------------------------------------------}-instance Eq a => Eq (Word64Map a) where-  t1 == t2  = equal t1 t2-  t1 /= t2  = nequal t1 t2--equal :: Eq a => Word64Map a -> Word64Map a -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)-equal (Tip kx x) (Tip ky y)-  = (kx == ky) && (x==y)-equal Nil Nil = True-equal _   _   = False--nequal :: Eq a => Word64Map a -> Word64Map a -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip kx x) (Tip ky y)-  = (kx /= ky) || (x/=y)-nequal Nil Nil = False-nequal _   _   = True---- | @since 0.5.9-instance Eq1 Word64Map where-  liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-    = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)-  liftEq eq (Tip kx x) (Tip ky y)-    = (kx == ky) && (eq x y)-  liftEq _eq Nil Nil = True-  liftEq _eq _   _   = False--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord a => Ord (Word64Map a) where-    compare m1 m2 = compare (toList m1) (toList m2)---- | @since 0.5.9-instance Ord1 Word64Map where-  liftCompare cmp m n =-    liftCompare (liftCompare cmp) (toList m) (toList n)--{---------------------------------------------------------------------  Functor---------------------------------------------------------------------}--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---------------------------------------------------------------------}--instance Show a => Show (Word64Map a) where-  showsPrec d m   = showParen (d > 10) $-    showString "fromList " . shows (toList m)---- | @since 0.5.9-instance Show1 Word64Map where-    liftShowsPrec sp sl d m =-        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)-      where-        sp' = liftShowsPrec sp sl-        sl' = liftShowList sp sl--{---------------------------------------------------------------------  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-    liftReadsPrec rp rl = readsData $-        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList-      where-        rp' = liftReadsPrec rp rl-        rl' = liftReadList rp rl--{---------------------------------------------------------------------  Helpers---------------------------------------------------------------------}-{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: Prefix -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a-link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2-{-# INLINE link #-}---- `linkWithMask` is useful when the `branchMask` has already been computed-linkWithMask :: Mask -> Prefix -> Word64Map a -> Word64Map a -> Word64Map a-linkWithMask m p1 t1 {-p2-} t2-  | zero p1 m = Bin p m t1 t2-  | otherwise = Bin p m t2 t1-  where-    p = mask p1 m-{-# INLINE linkWithMask #-}--{---------------------------------------------------------------------  @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a-bin _ _ l Nil = l-bin _ _ Nil r = r-bin p m l r   = Bin p m l r-{-# INLINE bin #-}---- binCheckLeft only checks that the left subtree is non-empty-binCheckLeft :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a-binCheckLeft _ _ Nil r = r-binCheckLeft p m l r   = Bin p m l r-{-# INLINE binCheckLeft #-}---- binCheckRight only checks that the right subtree is non-empty-binCheckRight :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a-binCheckRight _ _ l Nil = l-binCheckRight p m l r   = Bin p m l r-{-# INLINE binCheckRight #-}--{---------------------------------------------------------------------  Endian independent bit twiddling---------------------------------------------------------------------}---- | Should this key follow the left subtree of a 'Bin' with switching--- bit @m@? N.B., the answer is only valid when @match i p m@ is true.-zero :: Key -> Mask -> Bool-zero i m-  = (natFromInt i) .&. (natFromInt m) == 0-{-# INLINE zero #-}--nomatch,match :: Key -> Prefix -> Mask -> Bool---- | Does the key @i@ differ from the prefix @p@ before getting to--- the switching bit @m@?-nomatch i p m-  = (mask i m) /= p-{-# INLINE nomatch #-}---- | Does the key @i@ match the prefix @p@ (up to but not including--- bit @m@)?-match i p m-  = (mask i m) == p-{-# INLINE match #-}----- | The prefix of key @i@ up to (but not including) the switching--- bit @m@.-mask :: Key -> Mask -> Prefix-mask i m-  = maskW (natFromInt i) (natFromInt m)-{-# INLINE mask #-}---{---------------------------------------------------------------------  Big endian operations---------------------------------------------------------------------}---- | The prefix of key @i@ up to (but not including) the switching--- bit @m@.-maskW :: Nat -> Nat -> Prefix-maskW i m-  = intFromNat (i .&. ((-m) `xor` m))-{-# INLINE maskW #-}---- | Does the left switching bit specify a shorter prefix?-shorter :: Mask -> Mask -> Bool-shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)-{-# INLINE shorter #-}---- | The first switching bit where the two prefixes disagree.-branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2-  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-{-# INLINE branchMask #-}--{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}---- | \(O(1)\).  Decompose a map into pieces based on the structure--- of the underlying tree. This function is useful for consuming a--- map in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this.  However, it is guaranteed that the--- pieces returned will be in ascending order (all elements in the first submap--- less than all elements in the second, and so on).------ Examples:------ > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==--- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]------ > splitRoot empty == []------  Note that the current implementation does not return more than two submaps,---  but you should not depend on this behaviour because it can change in the---  future without notice.-splitRoot :: Word64Map a -> [Word64Map a]-splitRoot orig =-  case orig of-    Nil -> []-    x@(Tip _ _) -> [x]-    Bin _ m l r | m < 0 -> [r, l]-                | otherwise -> [l, r]-{-# INLINE splitRoot #-}---{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}---- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown--- in a compressed, hanging format.-showTree :: Show a => Word64Map a -> String-showTree s-  = showTreeWith True False s---{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows- the tree that implements the map. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--}-showTreeWith :: Show a => Bool -> Bool -> Word64Map a -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Show a => Bool -> [String] -> [String] -> Word64Map a -> ShowS-showsTree wide lbars rbars t = case t of-  Bin p m l r ->-    showsTree wide (withBar rbars) (withEmpty rbars) r .-    showWide wide rbars .-    showsBars lbars . showString (showBin p m) . showString "\n" .-    showWide wide lbars .-    showsTree wide (withEmpty lbars) (withBar lbars) l-  Tip k x ->-    showsBars lbars .-    showString " " . shows k . showString ":=" . shows x . showString "\n"-  Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Show a => Bool -> [String] -> Word64Map a -> ShowS-showsTreeHang wide bars t = case t of-  Bin p m l r ->-    showsBars bars . showString (showBin p m) . showString "\n" .-    showWide wide bars .-    showsTreeHang wide (withBar bars) l .-    showWide wide bars .-    showsTreeHang wide (withEmpty bars) r-  Tip k x ->-    showsBars bars .-    showString " " . shows k . showString ":=" . shows x . showString "\n"-  Nil -> showsBars bars . showString "|\n"--showBin :: Prefix -> Mask -> String-showBin _ _-  = "*" -- ++ show (p,m)--showWide :: Bool -> [String] -> String -> String-showWide wide bars-  | wide      = showString (concat (reverse bars)) . showString "|\n"-  | otherwise = id--showsBars :: [String] -> ShowS-showsBars bars-  = case bars of-      [] -> id-      _ : tl -> showString (concat (reverse tl)) . showString node--node :: String-node = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars
− compiler/GHC/Data/Word64Map/Lazy.hs 
@@ -1,236 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif----------------------------------------------------------------------------------- |--- Module      :  Data.Word64Map.Lazy--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Word64 Maps (lazy interface)------ The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)--- from keys of type @Word64@ to values of type @v@.------ The functions in "Data.Word64Map.Strict" are careful to force values before--- installing them in an 'Word64Map'. This is usually more efficient in cases where--- laziness is not essential. The functions in this module do not do so.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import Data.Word64Map.Lazy (Word64Map)--- > import qualified Data.Word64Map.Lazy as Word64Map------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.--------- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map and \(W\) referring to the number of bits in--- an 'Word64' (64).------ Benchmarks comparing "Data.Word64Map.Lazy" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.--------- == Implementation------ The implementation is based on /big-endian patricia trees/.  This data--- structure performs especially well on binary operations like 'union' and--- 'intersection'. Additionally, benchmarks show that it is also (much) faster--- on insertions and deletions when compared to a generic size-balanced map--- implementation (see "Data.Map").------    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",---      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.-----------------------------------------------------------------------------------module GHC.Data.Word64Map.Lazy (-    -- * Map type-#if !defined(TESTING)-    Word64Map, Key          -- instance Eq,Show-#else-    Word64Map(..), Key          -- instance Eq,Show-#endif--    -- * Construction-    , empty-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- * Deletion\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Query-    -- ** Lookup-    , WM.lookup-    , (!?)-    , (!)-    , findWithDefault-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE--    -- ** Size-    , WM.null-    , size--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , (\\)-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** Disjoint-    , disjoint--    -- ** Compose-    , compose--    -- ** Universal combining function-    , mergeWithKey--    -- * Traversal-    -- ** Map-    , WM.map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , WM.foldr-    , WM.foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList--    -- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , WM.filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey-    ) where--import GHC.Data.Word64Map.Internal as WM
− compiler/GHC/Data/Word64Map/Strict.hs 
@@ -1,254 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Data.Word64Map.Strict--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Word64 Maps (strict interface)------ The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)--- from key of type @Word64@ to values of type @v@.------ Each function in this module is careful to force values before installing--- them in an 'Word64Map'. This is usually more efficient when laziness is not--- necessary. When laziness /is/ required, use the functions in--- "Data.Word64Map.Lazy".------ In particular, the functions in this module obey the following law:------  - If all values stored in all maps in the arguments are in WHNF, then all---    values stored in all maps in the results will be in WHNF once those maps---    are evaluated.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import Data.Word64Map.Strict (Word64Map)--- > import qualified Data.Word64Map.Strict as Word64Map------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.--------- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map and \(W\) referring to the number of bits in--- an 'Word64' (64).------ Benchmarks comparing "Data.Word64Map.Strict" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.--------- == Warning------ The 'Word64Map' type is shared between the lazy and strict modules, meaning that--- the same 'Word64Map' value can be passed to functions in both modules. This--- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are--- the same as for the "Data.Word64Map.Lazy" module, so if they are used the--- resulting map may contain suspended values (thunks).--------- == Implementation------ The implementation is based on /big-endian patricia trees/.  This data--- structure performs especially well on binary operations like 'union' and--- 'intersection'. Additionally, benchmarks show that it is also (much) faster--- on insertions and deletions when compared to a generic size-balanced map--- implementation (see "Data.Map").------    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",---      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.------------------------------------------------------------------------------------- See the notes at the beginning of Data.Word64Map.Internal.--module GHC.Data.Word64Map.Strict (-    -- * Map type-#if !defined(TESTING)-    Word64Map, Key          -- instance Eq,Show-#else-    Word64Map(..), Key          -- instance Eq,Show-#endif--    -- * Construction-    , empty-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- * Deletion\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Query-    -- ** Lookup-    , lookup-    , (!?)-    , (!)-    , findWithDefault-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE--    -- ** Size-    , null-    , size--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , (\\)-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** Disjoint-    , disjoint--    -- ** Compose-    , compose--    -- ** Universal combining function-    , mergeWithKey--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList---- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey-    ) where--import GHC.Data.Word64Map.Strict.Internal-import Prelude ()
− compiler/GHC/Data/Word64Map/Strict/Internal.hs 
@@ -1,1206 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}--{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Word64Map.Strict.Internal--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Int Maps (strict interface)------ The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)--- from key of type @Int@ to values of type @v@.------ Each function in this module is careful to force values before installing--- them in an 'Word64Map'. This is usually more efficient when laziness is not--- necessary. When laziness /is/ required, use the functions in--- "Data.Word64Map.Lazy".------ In particular, the functions in this module obey the following law:------  - If all values stored in all maps in the arguments are in WHNF, then all---    values stored in all maps in the results will be in WHNF once those maps---    are evaluated.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import Data.Word64Map.Strict (Word64Map)--- > import qualified Data.Word64Map.Strict as Word64Map------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.--------- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map and \(W\) referring to the number of bits in--- an 'Int' (32 or 64).------ Benchmarks comparing "Data.Word64Map.Strict" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.--------- == Warning------ The 'Word64Map' type is shared between the lazy and strict modules, meaning that--- the same 'Word64Map' value can be passed to functions in both modules. This--- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are--- the same as for the "Data.Word64Map.Lazy" module, so if they are used the--- resulting map may contain suspended values (thunks).--------- == Implementation------ The implementation is based on /big-endian patricia trees/.  This data--- structure performs especially well on binary operations like 'union' and--- 'intersection'. Additionally, benchmarks show that it is also (much) faster--- on insertions and deletions when compared to a generic size-balanced map--- implementation (see "Data.Map").------    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",---      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.------------------------------------------------------------------------------------- See the notes at the beginning of Data.Word64Map.Internal.--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-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- * Deletion\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Query-    -- ** Lookup-    , lookup-    , (!?)-    , (!)-    , findWithDefault-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE--    -- ** Size-    , null-    , size--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , (\\)-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** Disjoint-    , disjoint--    -- ** Compose-    , compose--    -- ** Universal combining function-    , mergeWithKey--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList---- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey-    ) where--import GHC.Prelude.Basic hiding-  (lookup, filter, foldr, foldl, foldl', null, map)--import qualified GHC.Data.Word64Map.Internal as L-import GHC.Data.Word64Map.Internal-  ( Word64Map (..)-  , Key-  , mask-  , branchMask-  , nomatch-  , zero-  , natFromInt-  , intFromNat-  , bin-  , binCheckLeft-  , binCheckRight-  , link-  , linkWithMask--  , (\\)-  , (!)-  , (!?)-  , empty-  , assocs-  , filter-  , filterWithKey-  , findMin-  , findMax-  , foldMapWithKey-  , foldr-  , foldl-  , foldr'-  , foldl'-  , foldlWithKey-  , foldrWithKey-  , foldlWithKey'-  , foldrWithKey'-  , keysSet-  , mergeWithKey'-  , compose-  , delete-  , deleteMin-  , deleteMax-  , deleteFindMax-  , deleteFindMin-  , difference-  , elems-  , intersection-  , disjoint-  , isProperSubmapOf-  , isProperSubmapOfBy-  , isSubmapOf-  , isSubmapOfBy-  , lookup-  , lookupLE-  , lookupGE-  , lookupLT-  , lookupGT-  , lookupMin-  , lookupMax-  , minView-  , maxView-  , minViewWithKey-  , maxViewWithKey-  , keys-  , mapKeys-  , mapKeysMonotonic-  , member-  , notMember-  , null-  , partition-  , partitionWithKey-  , takeWhileAntitone-  , dropWhileAntitone-  , spanAntitone-  , restrictKeys-  , size-  , split-  , splitLookup-  , splitRoot-  , toAscList-  , toDescList-  , toList-  , union-  , unions-  , withoutKeys-  )-import qualified GHC.Data.Word64Set.Internal as Word64Set-import GHC.Utils.Containers.Internal.BitUtil-import GHC.Utils.Containers.Internal.StrictPair-import qualified Data.Foldable as Foldable--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}---- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@--- returns the value at key @k@ or returns @def@ when the key is not an--- element of the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See Word64Map.Internal.Note: Local 'go' functions and capturing]-findWithDefault :: a -> Key -> Word64Map a -> a-findWithDefault def !k = go-  where-    go (Bin p m l r) | nomatch k p m = def-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx x) | k == kx   = x-                  | otherwise = def-    go Nil = def--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | \(O(1)\). A map of one element.------ > singleton 1 'a'        == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: Key -> a -> Word64Map a-singleton k !x-  = Tip k x-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insert---------------------------------------------------------------------}--- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value, i.e. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty                         == singleton 5 'x'--insert :: Key -> a -> Word64Map a -> Word64Map a-insert !k !x t =-  case t of-    Bin p m l r-      | nomatch k p m -> link k (Tip k x) p t-      | zero k m      -> Bin p m (insert k x l) r-      | otherwise     -> Bin p m l (insert k x r)-    Tip ky _-      | k==ky         -> Tip k x-      | otherwise     -> link k (Tip k x) ky t-    Nil -> Tip k x---- right-biased insertion, used by 'union'--- | \(O(\min(n,W))\). Insert with a combining function.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f new_value old_value@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"--insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a-insertWith f k x t-  = insertWithKey (\_ x' y' -> f x' y') k x t---- | \(O(\min(n,W))\). Insert with a combining function.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f key new_value old_value@.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"------ If the key exists in the map, this function is lazy in @value@ but strict--- in the result of @f@.--insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a-insertWithKey f !k x t =-  case t of-    Bin p m l r-      | nomatch k p m -> link k (singleton k x) p t-      | zero k m      -> Bin p m (insertWithKey f k x l) r-      | otherwise     -> Bin p m l (insertWithKey f k x r)-    Tip ky y-      | k==ky         -> Tip k $! f k x y-      | otherwise     -> link k (singleton k x) ky t-    Nil -> singleton k x---- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])--insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)-insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0-  where-    go f k x t =-      case t of-        Bin p m l r-          | nomatch k p m -> Nothing :*: link k (singleton k x) p t-          | zero k m      -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)-          | otherwise     -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')-        Tip ky y-          | k==ky         -> (Just y :*: (Tip k $! f k x y))-          | otherwise     -> (Nothing :*: link k (singleton k x) ky t)-        Nil -> Nothing :*: (singleton k x)---{---------------------------------------------------------------------  Deletion---------------------------------------------------------------------}--- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty                         == empty--adjust ::  (a -> a) -> Key -> Word64Map a -> Word64Map a-adjust f k m-  = adjustWithKey (\_ x -> f x) k m---- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty                         == empty--adjustWithKey ::  (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a-adjustWithKey f !k t =-  case t of-    Bin p m l r-      | nomatch k p m -> t-      | zero k m      -> Bin p m (adjustWithKey f k l) r-      | otherwise     -> Bin p m l (adjustWithKey f k r)-    Tip ky y-      | k==ky         -> Tip ky $! f k y-      | otherwise     -> t-    Nil -> Nil---- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update ::  (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a-update f-  = updateWithKey (\_ x -> f x)---- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a-updateWithKey f !k t =-  case t of-    Bin p m l r-      | nomatch k p m -> t-      | zero k m      -> binCheckLeft p m (updateWithKey f k l) r-      | otherwise     -> binCheckRight p m l (updateWithKey f k r)-    Tip ky y-      | k==ky         -> case f k y of-                           Just !y' -> Tip ky y'-                           Nothing -> Nil-      | otherwise     -> t-    Nil -> Nil---- | \(O(\min(n,W))\). Lookup and update.--- The function returns original value, if it is updated.--- This is different behavior than 'Data.Map.updateLookupWithKey'.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")--updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)-updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0-  where-    go f k t =-      case t of-        Bin p m l r-          | nomatch k p m -> (Nothing :*: t)-          | zero k m      -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)-          | otherwise     -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')-        Tip ky y-          | k==ky         -> case f k y of-                               Just !y' -> (Just y :*: Tip ky y')-                               Nothing  -> (Just y :*: Nil)-          | otherwise     -> (Nothing :*: t)-        Nil -> (Nothing :*: Nil)------ | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.-alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a-alter f !k t =-  case t of-    Bin p m l r-      | nomatch k p m -> case f Nothing of-                           Nothing -> t-                           Just !x  -> link k (Tip k x) p t-      | zero k m      -> binCheckLeft p m (alter f k l) r-      | otherwise     -> binCheckRight p m l (alter f k r)-    Tip ky y-      | k==ky         -> case f (Just y) of-                           Just !x -> Tip ky x-                           Nothing -> Nil-      | otherwise     -> case f Nothing of-                           Just !x -> link k (Tip k x) ky t-                           Nothing -> t-    Nil               -> case f Nothing of-                           Just !x -> Tip k x-                           Nothing -> Nil---- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,--- or update a value in an 'Word64Map'.  In short : @'lookup' k <$> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)--- interactiveAlter k m = alterF f k m where---   f Nothing = do---      putStrLn $ show k ++---          " was not found in the map. Would you like to add it?"---      getUserResponse1 :: IO (Maybe String)---   f (Just old) = do---      putStrLn $ "The key is currently bound to " ++ show old ++---          ". Would you like to change or delete it?"---      getUserResponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map.---- Note: 'alterF' is a flipped version of the 'at' combinator from--- 'Control.Lens.At'.------ @since 0.5.8--alterF :: Functor f-       => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)--- This implementation was modified from 'Control.Lens.At'.-alterF f k m = (<$> f mv) $ \fres ->-  case fres of-    Nothing -> maybe m (const (delete k m)) mv-    Just !v' -> insert k v' m-  where mv = lookup k m---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of maps, with a combining operation.------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a-unionsWith f ts-  = Foldable.foldl' (unionWith f) empty ts---- | \(O(n+m)\). The union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a-unionWith f m1 m2-  = unionWithKey (\_ x y -> f x y) m1 m2---- | \(O(n+m)\). The union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a-unionWithKey f m1 m2-  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}---- | \(O(n+m)\). Difference with a combining function.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- >     == singleton 3 "b:B"--differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a-differenceWith f m1 m2-  = differenceWithKey (\_ x y -> f x y) m1 m2---- | \(O(n+m)\). Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference).--- If it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- >     == singleton 3 "3:b|B"--differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a-differenceWithKey f m1 m2-  = mergeWithKey f id (const Nil) m1 m2--{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}---- | \(O(n+m)\). The intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c-intersectionWith f m1 m2-  = intersectionWithKey (\_ x y -> f x y) m1 m2---- | \(O(n+m)\). The intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c-intersectionWithKey f m1 m2-  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2--{---------------------------------------------------------------------  MergeWithKey---------------------------------------------------------------------}---- | \(O(n+m)\). A high-performance universal combining function. Using--- 'mergeWithKey', all combining functions can be defined without any loss of--- efficiency (with exception of 'union', 'difference' and 'intersection',--- where sharing of some nodes is lost with 'mergeWithKey').------ Please make sure you know what is going on when using 'mergeWithKey',--- otherwise you can be surprised by unexpected code growth or even--- corruption of the data structure.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define your custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'Word64Map's is created, such that------ * if a key is present in both maps, it is passed with both corresponding---   values to the @combine@ function. Depending on the result, the key is either---   present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and---   the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and---   the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily.  Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or--- @'filterWithKey' f@ could be used for any @f@.--mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)-             -> Word64Map a -> Word64Map b -> Word64Map c-mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2-  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.-        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil-                                                                  Just !x -> Tip k1 x-        {-# INLINE combine #-}-{-# INLINE mergeWithKey #-}--{---------------------------------------------------------------------  Min\/Max---------------------------------------------------------------------}---- | \(O(\log n)\). Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a-updateMinWithKey f t =-  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)-            _ -> go f t-  where-    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r-    go f' (Tip k y) = case f' k y of-                        Just !y' -> Tip k y'-                        Nothing -> Nil-    go _ Nil = error "updateMinWithKey Nil"---- | \(O(\log n)\). Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a-updateMaxWithKey f t =-  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r-            _ -> go f t-  where-    go f' (Bin p m l r) = binCheckRight p m l (go f' r)-    go f' (Tip k y) = case f' k y of-                        Just !y' -> Tip k y'-                        Nothing -> Nil-    go _ Nil = error "updateMaxWithKey Nil"---- | \(O(\log n)\). Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a-updateMax f = updateMaxWithKey (const f)---- | \(O(\log n)\). Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a-updateMin f = updateMinWithKey (const f)---{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | \(O(n)\). Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> Word64Map a -> Word64Map b-map f = go-  where-    go (Bin p m l r) = Bin p m (go l) (go r)-    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.------ > let f key x = (show key) ++ ":" ++ x--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]--mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b-mapWithKey f t-  = case t of-      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)-      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.------ TODO Consider moving map and mapWithKey to Word64Map.Internal so we can write--- non-orphan RULES for things like L.map f (map g xs). We'd need a new function--- for this, and we'd have to pay attention to simplifier phases. Something like------ lsmap :: (b -> c) -> (a -> b) -> Word64Map a -> Word64Map c--- lsmap _ _ Nil = Nil--- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)--- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)-{-# NOINLINE [1] mapWithKey #-}-{-# RULES-"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =-  mapWithKey (\k a -> f k $! g k a) xs-"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) =-  mapWithKey (\k a -> f k (g k a)) xs-"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =-  mapWithKey (\k a -> f k $! g a) xs-"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) =-  mapWithKey (\k a -> f k (g a)) xs-"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =-  mapWithKey (\k a -> f $! g k a) xs-"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)@--- That is, behaves exactly like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing-traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)-traverseWithKey f = go-  where-    go Nil = pure Nil-    go (Tip k v) = (\ !v' -> Tip k v') <$> f k v-    go (Bin p m l r)-      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)-      | otherwise = liftA2 (Bin p m) (go l) (go r)-{-# INLINE traverseWithKey #-}---- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.------ @since 0.6.4-traverseMaybeWithKey-  :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)-traverseMaybeWithKey f = go-    where-    go Nil           = pure Nil-    go (Tip k x)     = maybe Nil (Tip k $!) <$> f k x-    go (Bin p m l r)-      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)-      | otherwise = liftA2 (bin p m) (go l) (go r)---- | \(O(n)\). The function @'mapAccum'@ threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)---- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccumWithKey f a t-  = mapAccumL f a t---- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating--- argument through the map in ascending order of keys.  Strict in--- the accumulating argument and the both elements of the--- result of the function.-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0-  where-    go f a t-      = case t of-          Bin p m l r-            | m < 0 ->-                let (a1 :*: r') = go f a r-                    (a2 :*: l') = go f a1 l-                in (a2 :*: Bin p m l' r')-            | otherwise ->-                let (a1 :*: l') = go f a l-                    (a2 :*: r') = go f a1 r-                in (a2 :*: Bin p m l' r')-          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')-          Nil         -> (a :*: Nil)---- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)-mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0-  where-    go f a t-      = case t of-          Bin p m l r-            | m < 0 ->-              let (a1 :*: l') = go f a l-                  (a2 :*: r') = go f a1 r-              in (a2 :*: Bin p m l' r')-            | otherwise ->-              let (a1 :*: r') = go f a r-                  (a2 :*: l') = go f a1 l-              in (a2 :*: Bin p m l' r')-          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')-          Nil         -> (a :*: Nil)---- | \(O(n \log n)\).--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []--{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | \(O(n)\). Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | \(O(n)\). Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b-mapMaybeWithKey f (Bin p m l r)-  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)-mapMaybeWithKey f (Tip k x) = case f k x of-  Just !y  -> Tip k y-  Nothing -> Nil-mapMaybeWithKey _ Nil = Nil---- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)-mapEither f m-  = mapEitherWithKey (\_ x -> f x) m---- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0-  where-    go f (Bin p m l r)-      = bin p m l1 r1 :*: bin p m l2 r2-      where-        (l1 :*: l2) = go f l-        (r1 :*: r2) = go f r-    go f (Tip k x) = case f k x of-      Left !y  -> (Tip k y :*: Nil)-      Right !z -> (Nil :*: Tip k z)-    go _ Nil = (Nil :*: Nil)--{---------------------------------------------------------------------  Conversions---------------------------------------------------------------------}---- | \(O(n)\). Build a map from a set of keys and a function which for each key--- computes its value.------ > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.Word64Set.empty == empty--fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a-fromSet _ Word64Set.Nil = Nil-fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)-fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)-  where -- This is slightly complicated, as we to convert the dense-        -- representation of Word64Set into tree representation of Word64Map.-        ---        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.-        -- We split bmask into halves corresponding to left and right subtree.-        -- If they are both nonempty, we create a Bin node, otherwise exactly-        -- one of them is nonempty and we construct the Word64Map from that half.-        buildTree g !prefix !bmask bits = case bits of-          0 -> Tip prefix $! g prefix-          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of-                 bits2 | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->-                           buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2-                       | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->-                           buildTree g prefix bmask bits2-                       | otherwise ->-                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}--- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]--fromList :: [(Key,a)] -> Word64Map a-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x)  = insert k x t---- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a-fromListWith f xs-  = fromListWithKey (\_ x y -> f x y) xs---- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.------ > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]--- > fromListWithKey f [] == empty--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order.------ > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--fromAscList :: [(Key,a)] -> Word64Map a-fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)-{-# NOINLINE fromAscList #-}---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a-fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)-{-# NOINLINE fromAscListWith #-}---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a-fromAscListWithKey f = fromMonoListWithKey Nondistinct f-{-# NOINLINE fromAscListWithKey #-}---- | \(O(n)\). Build a map from a list of key\/value pairs where--- the keys are in ascending order and all distinct.--- /The precondition (input list is strictly ascending) is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--fromDistinctAscList :: [(Key,a)] -> Word64Map a-fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)-{-# NOINLINE fromDistinctAscList #-}---- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys--- and a combining function.------ The precise conditions under which this function works are subtle:--- For any branch mask, keys with the same prefix w.r.t. the branch--- mask must occur consecutively in the list.--fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a-fromMonoListWithKey distinct f = go-  where-    go []              = Nil-    go ((kx,vx) : zs1) = addAll' kx vx zs1--    -- `addAll'` collects all keys equal to `kx` into a single value,-    -- and then proceeds with `addAll`.-    addAll' !kx vx []-        = Tip kx $! vx-    addAll' !kx vx ((ky,vy) : zs)-        | Nondistinct <- distinct, kx == ky-        = let !v = f kx vy vx in addAll' ky v zs-        -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)-        | m <- branchMask kx ky-        , Inserted ty zs' <- addMany' m ky vy zs-        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'--    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`-    -- `addAll` consumes the rest of the list, adding to the tree `tx`-    addAll !_kx !tx []-        = tx-    addAll !kx !tx ((ky,vy) : zs)-        | m <- branchMask kx ky-        , Inserted ty zs' <- addMany' m ky vy zs-        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'--    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.-    addMany' !_m !kx vx []-        = Inserted (Tip kx $! vx) []-    addMany' !m !kx vx zs0@((ky,vy) : zs)-        | Nondistinct <- distinct, kx == ky-        = let !v = f kx vy vx in addMany' m ky v zs-        -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)-        | mask kx m /= mask ky m-        = Inserted (Tip kx $! vx) zs0-        | mxy <- branchMask kx ky-        , Inserted ty zs' <- addMany' mxy ky vy zs-        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'--    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.-    addMany !_m !_kx tx []-        = Inserted tx []-    addMany !m !kx tx zs0@((ky,vy) : zs)-        | mask kx m /= mask ky m-        = Inserted tx zs0-        | mxy <- branchMask kx ky-        , Inserted ty zs' <- addMany' mxy ky vy zs-        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'-{-# INLINE fromMonoListWithKey #-}--data Inserted a = Inserted !(Word64Map a) ![(Key,a)]--data Distinct = Distinct | Nondistinct
− compiler/GHC/Data/Word64Set.hs 
@@ -1,172 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Data.Word64Set--- Copyright   :  (c) Daan Leijen 2002---                (c) Joachim Breitner 2011--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Int Sets------ The @'Word64Set'@ type represents a set of elements of type @Int@.------ For a walkthrough of the most commonly used functions see their--- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import Data.Word64Set (Word64Set)--- >  import qualified Data.Word64Set as Word64Set--------- == Performance information------ Many operations have a worst-case complexity of \(O(\min(n,W))\).--- This means that the operation can become linear in the number of--- elements with a maximum of \(W\) -- the number of bits in an 'Int'--- (32 or 64).--------- == Implementation------ The implementation is based on /big-endian patricia trees/.  This data--- structure performs especially well on binary operations like 'union'--- and 'intersection'.  However, my benchmarks show that it is also--- (much) faster on insertions and deletions when compared to a generic--- size-balanced set implementation (see "Data.Set").------    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",---      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.------ Additionally, this implementation places bitmaps in the leaves of the tree.--- Their size is the natural size of a machine word (32 or 64 bits) and greatly--- reduces the memory footprint and execution times for dense sets, e.g. sets--- where it is likely that many values lie close to each other. The asymptotics--- are not affected by this optimization.-----------------------------------------------------------------------------------module GHC.Data.Word64Set (-            -- * Strictness properties-            -- $strictness--            -- * Set type-#if !defined(TESTING)-              Word64Set          -- instance Eq,Show-#else-              Word64Set(..)      -- instance Eq,Show-#endif-            , Key--            -- * Construction-            , empty-            , singleton-            , fromList-            , fromAscList-            , fromDistinctAscList--            -- * Insertion-            , insert--            -- * Deletion-            , delete--            -- * Generalized insertion/deletion-            , alterF--            -- * Query-            , member-            , notMember-            , lookupLT-            , lookupGT-            , lookupLE-            , lookupGE-            , WS.null-            , size-            , isSubsetOf-            , isProperSubsetOf-            , disjoint--            -- * Combine-            , union-            , unions-            , difference-            , (\\)-            , intersection--            -- * Filter-            , WS.filter-            , partition--            , takeWhileAntitone-            , dropWhileAntitone-            , spanAntitone--            , split-            , splitMember-            , splitRoot--            -- * Map-            , WS.map-            , mapMonotonic--            -- * Folds-            , WS.foldr-            , WS.foldl-            -- ** Strict folds-            , foldr'-            , foldl'-            -- ** Legacy folds-            , fold--            -- * Min\/Max-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax-            , maxView-            , minView--            -- * Conversion--            -- ** List-            , elems-            , toList-            , toAscList-            , toDescList--            -- * Debugging-            , showTree-            , showTreeWith--#if defined(TESTING)-            -- * Internals-            , match-#endif-            ) where--import GHC.Data.Word64Set.Internal as WS---- $strictness------ This module satisfies the following strictness property:------ * Key arguments are evaluated to WHNF------ Here are some examples that illustrate the property:------ > delete undefined s  ==  undefined
− compiler/GHC/Data/Word64Set/Internal.hs 
@@ -1,1702 +0,0 @@-{-# 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 #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Word64Set.Internal--- Copyright   :  (c) Daan Leijen 2002---                (c) Joachim Breitner 2011--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ The contents of this module may change __in any way whatsoever__--- and __without any warning__ between minor versions of this package.------ Authors importing this module are expected to track development--- closely.------ = Description------ An efficient implementation of integer sets.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import Data.Word64Set (Word64Set)--- >  import qualified Data.Word64Set as Word64Set------ The implementation is based on /big-endian patricia trees/.  This data--- structure performs especially well on binary operations like 'union'--- and 'intersection'.  However, my benchmarks show that it is also--- (much) faster on insertions and deletions when compared to a generic--- size-balanced set implementation (see "Data.Set").------    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",---      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.------ Additionally, this implementation places bitmaps in the leaves of the tree.--- Their size is the natural size of a machine word (32 or 64 bits) and greatly--- reduce memory footprint and execution times for dense sets, e.g. sets where--- it is likely that many values lie close to each other. The asymptotics are--- not affected by this optimization.------ Many operations have a worst-case complexity of \(O(\min(n,W))\).--- This means that the operation can become linear in the number of--- elements with a maximum of \(W\) -- the number of bits in an 'Int'--- (32 or 64).------ @since 0.5.9---------------------------------------------------------------------------------- [Note: INLINE bit fiddling]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- It is essential that the bit fiddling functions like mask, zero, branchMask--- etc are inlined. If they do not, the memory allocation skyrockets. The GHC--- usually gets it right, but it is disastrous if it does not. Therefore we--- explicitly mark these functions INLINE.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Care must be taken when using 'go' function which captures an argument.--- Sometimes (for example when the argument is passed to a data constructor,--- as in insert), GHC heap-allocates more than necessary. Therefore C-- code--- must be checked for increased allocation when creating and modifying such--- functions.----- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of Word64Set matters when considering performance.--- Currently in GHC 7.0, when type has 3 constructors, they are matched from--- the first to the last -- the best performance is achieved when the--- constructors are ordered by frequency.--- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil--- improves the benchmark by circa 10%.--module GHC.Data.Word64Set.Internal (-    -- * Set type-      Word64Set(..), Key -- instance Eq,Show-    , Prefix, Mask, BitMap--    -- * Operators-    , (\\)--    -- * Query-    , null-    , size-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE-    , isSubsetOf-    , isProperSubsetOf-    , disjoint--    -- * Construction-    , empty-    , singleton-    , insert-    , delete-    , alterF--    -- * Combine-    , union-    , unions-    , difference-    , intersection--    -- * Filter-    , filter-    , partition--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , split-    , splitMember-    , splitRoot--    -- * Map-    , map-    , mapMonotonic--    -- * Folds-    , foldr-    , foldl-    -- ** Strict folds-    , foldr'-    , foldl'-    -- ** Legacy folds-    , fold--    -- * Min\/Max-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , maxView-    , minView--    -- * Conversion--    -- ** List-    , elems-    , toList-    , fromList--    -- ** Ordered list-    , toAscList-    , toDescList-    , fromAscList-    , fromDistinctAscList--    -- * Debugging-    , showTree-    , showTreeWith--    -- * Internals-    , match-    , suffixBitMask-    , prefixBitMask-    , bitmapOf-    , zero-    ) where--import Control.Applicative (Const(..))-import Control.DeepSeq (NFData(rnf))-import Data.Bits-import qualified Data.List as List-import Data.Maybe (fromMaybe)-import Data.Semigroup (Semigroup(stimes, (<>)), stimesIdempotentMonoid)-import GHC.Prelude.Basic hiding-  (filter, foldr, foldl, foldl', null, map)-import Data.Word ( Word64 )--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 -}---- A "Nat" is a 64 bit machine word-type Nat = Word64--natFromInt :: Word64 -> Nat-natFromInt = id-{-# INLINE natFromInt #-}--intFromNat :: Nat -> Word64-intFromNat = id-{-# INLINE intFromNat #-}--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}--- | \(O(n+m)\). See 'difference'.-(\\) :: Word64Set -> Word64Set -> Word64Set-m1 \\ m2 = difference m1 m2--{---------------------------------------------------------------------  Types---------------------------------------------------------------------}---- | A set of integers.---- See Note: Order of constructors-data Word64Set = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !Word64Set !Word64Set--- Invariant: Nil is never found as a child of Bin.--- Invariant: The Mask is a power of 2.  It is the largest bit position at which---            two elements of the set differ.--- Invariant: Prefix is the common high-order bits that all elements share to---            the left of the Mask bit.--- Invariant: In Bin prefix mask left right, left consists of the elements that---            don't have the mask bit set; right is all the elements that do.-            | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap--- Invariant: The Prefix is zero for the last 6 bits. The values of the set---            represented by a tip are the prefix plus the indices of the set---            bits in the bit map.-            | Nil---- A number stored in a set is stored as--- * Prefix (all but last 6 bits) and--- * BitMap (last 6 bits stored as a bitmask)---   Last 6 bits are called a Suffix.--type Prefix = Word64-type Mask   = Word64-type BitMap = Word64-type Key    = Word64--instance Monoid Word64Set where-    mempty  = empty-    mconcat = unions-    mappend = (<>)---- | @since 0.5.7-instance Semigroup Word64Set where-    (<>)    = union-    stimes  = stimesIdempotentMonoid--#if __GLASGOW_HASKELL__--{---------------------------------------------------------------------  A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data Word64Set where-  gfoldl f z is = z fromList `f` (toList is)-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = intSetDataType--fromListConstr :: Constr-fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix--intSetDataType :: DataType-intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | \(O(1)\). Is the set empty?-null :: Word64Set -> Bool-null Nil = True-null _   = False-{-# INLINE null #-}---- | \(O(n)\). Cardinality of the set.-size :: Word64Set -> Int-size = go 0-  where-    go !acc (Bin _ _ l r) = go (go acc l) r-    go acc (Tip _ bm) = acc + bitcount 0 bm-    go acc Nil = acc---- | \(O(\min(n,W))\). Is the value a member of the set?---- See Note: Local 'go' functions and capturing.-member :: Key -> Word64Set -> Bool-member !x = go-  where-    go (Bin p m l r)-      | nomatch x p m = False-      | zero x m      = go l-      | otherwise     = go r-    go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0-    go Nil = False---- | \(O(\min(n,W))\). Is the element not in the set?-notMember :: Key -> Word64Set -> Bool-notMember k = not . member k---- | \(O(\min(n,W))\). Find largest element smaller than the given one.------ > lookupLT 3 (fromList [3, 5]) == Nothing--- > lookupLT 5 (fromList [3, 5]) == Just 3---- See Note: Local 'go' functions and capturing.-lookupLT :: Key -> Word64Set -> Maybe Key-lookupLT !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r-                         | zero x m  = go def l-                         | otherwise = go l r-    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm-                       | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT-                       | otherwise = unsafeFindMax def-                       where maskLT = (bitmapOf x - 1) .&. bm-    go def Nil = unsafeFindMax def----- | \(O(\min(n,W))\). Find smallest element greater than the given one.------ > lookupGT 4 (fromList [3, 5]) == Just 5--- > lookupGT 5 (fromList [3, 5]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGT :: Key -> Word64Set -> Maybe Key-lookupGT !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def-                         | zero x m  = go r l-                         | otherwise = go def r-    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm-                       | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT-                       | otherwise = unsafeFindMin def-                       where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm-    go def Nil = unsafeFindMin def----- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.------ > lookupLE 2 (fromList [3, 5]) == Nothing--- > lookupLE 4 (fromList [3, 5]) == Just 3--- > lookupLE 5 (fromList [3, 5]) == Just 5---- See Note: Local 'go' functions and capturing.-lookupLE :: Key -> Word64Set -> Maybe Key-lookupLE !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r-                         | zero x m  = go def l-                         | otherwise = go l r-    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm-                       | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE-                       | otherwise = unsafeFindMax def-                       where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm-    go def Nil = unsafeFindMax def----- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.------ > lookupGE 3 (fromList [3, 5]) == Just 3--- > lookupGE 4 (fromList [3, 5]) == Just 5--- > lookupGE 6 (fromList [3, 5]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGE :: Key -> Word64Set -> Maybe Key-lookupGE !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def-                         | zero x m  = go r l-                         | otherwise = go def r-    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm-                       | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE-                       | otherwise = unsafeFindMin def-                       where maskGE = (- (bitmapOf x)) .&. bm-    go def Nil = unsafeFindMin def------ Helper function for lookupGE and lookupGT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMin :: Word64Set -> Maybe Key-unsafeFindMin Nil = Nothing-unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm-unsafeFindMin (Bin _ _ l _) = unsafeFindMin l---- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMax :: Word64Set -> Maybe Key-unsafeFindMax Nil = Nothing-unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm-unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | \(O(1)\). The empty set.-empty :: Word64Set-empty-  = Nil-{-# INLINE empty #-}---- | \(O(1)\). A set of one element.-singleton :: Key -> Word64Set-singleton x-  = Tip (prefixOf x) (bitmapOf x)-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insert---------------------------------------------------------------------}--- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for--- Word64Sets.-insert :: Key -> Word64Set -> Word64Set-insert !x = insertBM (prefixOf x) (bitmapOf x)---- Helper function for insert and union.-insertBM :: Prefix -> BitMap -> Word64Set -> Word64Set-insertBM !kx !bm t@(Bin p m l r)-  | nomatch kx p m = link kx (Tip kx bm) p t-  | zero kx m      = Bin p m (insertBM kx bm l) r-  | otherwise      = Bin p m l (insertBM kx bm r)-insertBM kx bm t@(Tip kx' bm')-  | kx' == kx = Tip kx' (bm .|. bm')-  | otherwise = link kx (Tip kx bm) kx' t-insertBM kx bm Nil = Tip kx bm---- | \(O(\min(n,W))\). Delete a value in the set. Returns the--- original set when the value was not present.-delete :: Key -> Word64Set -> Word64Set-delete !x = deleteBM (prefixOf x) (bitmapOf x)---- Deletes all values mentioned in the BitMap from the set.--- Helper function for delete and difference.-deleteBM :: Prefix -> BitMap -> Word64Set -> Word64Set-deleteBM !kx !bm t@(Bin p m l r)-  | nomatch kx p m = t-  | zero kx m      = bin p m (deleteBM kx bm l) r-  | otherwise      = bin p m l (deleteBM kx bm r)-deleteBM kx bm t@(Tip kx' bm')-  | kx' == kx = tip kx (bm' .&. complement bm)-  | otherwise = t-deleteBM _ _ Nil = Nil---- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending--- on whether it is already present in @s@.------ In short:------ @--- 'member' x \<$\> 'alterF' f x s = f ('member' x s)--- @------ Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".------ @since 0.6.3.1-alterF :: Functor f => (Bool -> f Bool) -> Key -> Word64Set -> f Word64Set-alterF f k s = fmap choose (f member_)-  where-    member_ = member k s--    (inserted, deleted)-      | member_   = (s         , delete k s)-      | otherwise = (insert k s, s         )--    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 #-}--{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of sets.-unions :: Foldable f => f Word64Set -> Word64Set-unions xs-  = Foldable.foldl' union empty xs----- | \(O(n+m)\). The union of two sets.-union :: Word64Set -> Word64Set -> Word64Set-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = union1-  | shorter m2 m1  = union2-  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)-  | otherwise      = link p1 t1 p2 t2-  where-    union1  | nomatch p2 p1 m1  = link p1 t1 p2 t2-            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1-            | otherwise         = Bin p1 m1 l1 (union r1 t2)--    union2  | nomatch p1 p2 m2  = link p1 t1 p2 t2-            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2-            | otherwise         = Bin p2 m2 l2 (union t1 r2)--union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t-union t@(Bin _ _ _ _) Nil = t-union (Tip kx bm) t = insertBM kx bm t-union Nil t = t---{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | \(O(n+m)\). Difference between two sets.-difference :: Word64Set -> Word64Set -> Word64Set-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = difference1-  | shorter m2 m1  = difference2-  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)-  | otherwise      = t1-  where-    difference1 | nomatch p2 p1 m1  = t1-                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1-                | otherwise         = bin p1 m1 l1 (difference r1 t2)--    difference2 | nomatch p1 p2 m2  = t1-                | zero p1 m2        = difference t1 l2-                | otherwise         = difference t1 r2--difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t-difference t@(Bin _ _ _ _) Nil = t--difference t1@(Tip kx bm) t2 = differenceTip t2-  where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1-                                        | zero kx m2 = differenceTip l2-                                        | otherwise = differenceTip r2-        differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)-                                    | otherwise = t1-        differenceTip Nil = t1--difference Nil _     = Nil----{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | \(O(n+m)\). The intersection of two sets.-intersection :: Word64Set -> Word64Set -> Word64Set-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = intersection1-  | shorter m2 m1  = intersection2-  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)-  | otherwise      = Nil-  where-    intersection1 | nomatch p2 p1 m1  = Nil-                  | zero p2 m1        = intersection l1 t2-                  | otherwise         = intersection r1 t2--    intersection2 | nomatch p1 p2 m2  = Nil-                  | zero p1 m2        = intersection t1 l2-                  | otherwise         = intersection t1 r2--intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1-  where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil-                                      | zero kx2 m1       = intersectBM l1-                                      | otherwise         = intersectBM r1-        intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)-                                  | otherwise = Nil-        intersectBM Nil = Nil--intersection (Bin _ _ _ _) Nil = Nil--intersection (Tip kx1 bm1) t2 = intersectBM t2-  where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil-                                      | zero kx1 m2       = intersectBM l2-                                      | otherwise         = intersectBM r2-        intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)-                                  | otherwise = Nil-        intersectBM Nil = Nil--intersection Nil _ = Nil--{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | \(O(n+m)\). Is this a proper subset? (ie. a subset but not equal).-isProperSubsetOf :: Word64Set -> Word64Set -> Bool-isProperSubsetOf t1 t2-  = case subsetCmp t1 t2 of-      LT -> True-      _  -> False--subsetCmp :: Word64Set -> Word64Set -> Ordering-subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = GT-  | shorter m2 m1  = case subsetCmpLt of-                       GT -> GT-                       _  -> LT-  | p1 == p2       = subsetCmpEq-  | otherwise      = GT  -- disjoint-  where-    subsetCmpLt | nomatch p1 p2 m2  = GT-                | zero p1 m2        = subsetCmp t1 l2-                | otherwise         = subsetCmp t1 r2-    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of-                    (GT,_ ) -> GT-                    (_ ,GT) -> GT-                    (EQ,EQ) -> EQ-                    _       -> LT--subsetCmp (Bin _ _ _ _) _  = GT-subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)-  | kx1 /= kx2                  = GT -- disjoint-  | bm1 == bm2                  = EQ-  | bm1 .&. complement bm2 == 0 = LT-  | otherwise                   = GT-subsetCmp t1@(Tip kx _) (Bin p m l r)-  | nomatch kx p m = GT-  | zero kx m      = case subsetCmp t1 l of GT -> GT ; _ -> LT-  | otherwise      = case subsetCmp t1 r of GT -> GT ; _ -> LT-subsetCmp (Tip _ _) Nil = GT -- disjoint-subsetCmp Nil Nil = EQ-subsetCmp Nil _   = LT---- | \(O(n+m)\). Is this a subset?--- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.--isSubsetOf :: Word64Set -> Word64Set -> Bool-isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = False-  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2-                                                      else isSubsetOf t1 r2)-  | otherwise      = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2-isSubsetOf (Bin _ _ _ _) _  = False-isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0-isSubsetOf t1@(Tip kx _) (Bin p m l r)-  | nomatch kx p m = False-  | zero kx m      = isSubsetOf t1 l-  | otherwise      = isSubsetOf t1 r-isSubsetOf (Tip _ _) Nil = False-isSubsetOf Nil _         = True---{---------------------------------------------------------------------  Disjoint---------------------------------------------------------------------}--- | \(O(n+m)\). Check whether two sets are disjoint (i.e. their intersection---   is empty).------ > disjoint (fromList [2,4,6])   (fromList [1,3])     == True--- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False--- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False--- > disjoint (fromList [])        (fromList [])        == True------ @since 0.5.11-disjoint :: Word64Set -> Word64Set -> Bool-disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = disjoint1-  | shorter m2 m1  = disjoint2-  | p1 == p2       = disjoint l1 l2 && disjoint r1 r2-  | otherwise      = True-  where-    disjoint1 | nomatch p2 p1 m1  = True-              | zero p2 m1        = disjoint l1 t2-              | otherwise         = disjoint r1 t2--    disjoint2 | nomatch p1 p2 m2  = True-              | zero p1 m2        = disjoint t1 l2-              | otherwise         = disjoint t1 r2--disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1-  where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True-                                     | zero kx2 m1       = disjointBM l1-                                     | otherwise         = disjointBM r1-        disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0-                                 | otherwise = True-        disjointBM Nil = True--disjoint (Bin _ _ _ _) Nil = True--disjoint (Tip kx1 bm1) t2 = disjointBM t2-  where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True-                                     | zero kx1 m2       = disjointBM l2-                                     | otherwise         = disjointBM r2-        disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0-                                 | otherwise = True-        disjointBM Nil = True--disjoint Nil _ = True---{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | \(O(n)\). Filter all elements that satisfy some predicate.-filter :: (Key -> Bool) -> Word64Set -> Word64Set-filter predicate t-  = case t of-      Bin p m l r-        -> bin p m (filter predicate l) (filter predicate r)-      Tip kx bm-        -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)-      Nil -> Nil-  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi-                         | otherwise           = bm-        {-# INLINE bitPred #-}---- | \(O(n)\). partition the set according to some predicate.-partition :: (Key -> Bool) -> Word64Set -> (Word64Set,Word64Set)-partition predicate0 t0 = toPair $ go predicate0 t0-  where-    go predicate t-      = case t of-          Bin p m l r-            -> let (l1 :*: l2) = go predicate l-                   (r1 :*: r2) = go predicate r-               in bin p m l1 r1 :*: bin p m l2 r2-          Tip kx bm-            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm-               in  tip kx bm1 :*: tip kx (bm `xor` bm1)-          Nil -> (Nil :*: Nil)-      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi-                             | otherwise           = bm-            {-# INLINE bitPred #-}---- | \(O(\min(n,W))\). Take while a predicate on the elements holds.--- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.--- See note at 'spanAntitone'.------ @--- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'--- takeWhileAntitone p = 'filter' p--- @------ @since 0.6.7-takeWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set-takeWhileAntitone predicate t =-  case t of-    Bin p m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then bin p m (go predicate l) r-        else go predicate r-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = bin p m l (go predicate' r)-      | otherwise         = go predicate' l-    go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)-    go _ Nil = Nil---- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.--- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.--- See note at 'spanAntitone'.------ @--- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'--- dropWhileAntitone p = 'filter' (not . p)--- @------ @since 0.6.7-dropWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set-dropWhileAntitone predicate t =-  case t of-    Bin p m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then go predicate l-        else bin p m l (go predicate r)-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = go predicate' r-      | otherwise         = bin p m (go predicate' l) r-    go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)-    go _ Nil = Nil---- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.--- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.------ @--- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)--- spanAntitone p xs = 'partition' p xs--- @------ Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set--- at some /unspecified/ point.------ @since 0.6.7-spanAntitone :: (Key -> Bool) -> Word64Set -> (Word64Set, Word64Set)-spanAntitone predicate t =-  case t of-    Bin p m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then-          case go predicate l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go predicate r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go predicate t of-          (lt :*: gt) -> (lt, gt)-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt-      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r-    go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm-                                in (tip kx bm' :*: tip kx (bm `xor` bm'))-    go _ Nil = (Nil :*: Nil)---- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@--- where @set1@ comprises the elements of @set@ less than @x@ and @set2@--- comprises the elements of @set@ greater than @x@.------ > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])-split :: Key -> Word64Set -> (Word64Set,Word64Set)-split x t =-  case t of-    Bin p m l r-      | m < 0 ->-        if x >= 0  -- handle negative numbers.-        then-          case go x l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go x r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go x t of-          (lt :*: gt) -> (lt, gt)-  where-    go !x' t'@(Bin p m l r)-        | nomatch x' p m = if x' < p then (Nil :*: t') else (t' :*: Nil)-        | zero x' m      = case go x' l of (lt :*: gt) -> lt :*: bin p m gt r-        | otherwise      = case go x' r of (lt :*: gt) -> bin p m l lt :*: gt-    go x' t'@(Tip kx' bm)-        | kx' > x'          = (Nil :*: t')-          -- equivalent to kx' > prefixOf x'-        | kx' < prefixOf x' = (t' :*: Nil)-        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)-            where lowerBitmap = bitmapOf x' - 1-                  higherBitmap = complement (lowerBitmap + bitmapOf x')-    go _ Nil = (Nil :*: Nil)---- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Key -> Word64Set -> (Word64Set,Bool,Word64Set)-splitMember x t =-  case t of-    Bin p m l r-      | m < 0 ->-        if x >= 0 -- handle negative numbers.-        then-          case go x l of-            (lt, fnd, gt) ->-              let !lt' = bin p m lt r-              in (lt', fnd, gt)-        else-          case go x r of-            (lt, fnd, gt) ->-              let !gt' = bin p m l gt-              in (lt, fnd, gt')-    _ -> go x t-  where-    go x' t'@(Bin p m l r)-        | nomatch x' p m = if x' < p then (Nil, False, t') else (t', False, Nil)-        | zero x' m =-          case go x' l of-            (lt, fnd, gt) ->-              let !gt' = bin p m gt r-              in (lt, fnd, gt')-        | otherwise =-          case go x' r of-            (lt, fnd, gt) ->-              let !lt' = bin p m l lt-              in (lt', fnd, gt)-    go x' t'@(Tip kx' bm)-        | kx' > x'          = (Nil, False, t')-          -- equivalent to kx' > prefixOf x'-        | kx' < prefixOf x' = (t', False, Nil)-        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)-                          !found = (bm .&. bitmapOfx') /= 0-                          !gt = tip kx' (bm .&. higherBitmap)-                      in (lt, found, gt)-            where bitmapOfx' = bitmapOf x'-                  lowerBitmap = bitmapOfx' - 1-                  higherBitmap = complement (lowerBitmap + bitmapOfx')-    go _ Nil = (Nil, False, Nil)--{-----------------------------------------------------------------------  Min/Max-----------------------------------------------------------------------}---- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-maxView :: Word64Set -> Maybe (Key, Word64Set)-maxView t =-  case t of Nil -> Nothing-            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)-            _ -> Just (go t)-  where-    go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')-    go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))-    go Nil = error "maxView Nil"---- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-minView :: Word64Set -> Maybe (Key, Word64Set)-minView t =-  case t of Nil -> Nothing-            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')-            _ -> Just (go t)-  where-    go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)-    go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))-    go Nil = error "minView Nil"---- | \(O(\min(n,W))\). Delete and find the minimal element.------ > deleteFindMin set = (findMin set, deleteMin set)-deleteFindMin :: Word64Set -> (Key, Word64Set)-deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView---- | \(O(\min(n,W))\). Delete and find the maximal element.------ > deleteFindMax set = (findMax set, deleteMax set)-deleteFindMax :: Word64Set -> (Key, Word64Set)-deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView----- | \(O(\min(n,W))\). The minimal element of the set.-findMin :: Word64Set -> Key-findMin Nil = error "findMin: empty set has no minimal element"-findMin (Tip kx bm) = kx + lowestBitSet bm-findMin (Bin _ m l r)-  |   m < 0   = find r-  | otherwise = find l-    where find (Tip kx bm) = kx + lowestBitSet bm-          find (Bin _ _ l' _) = find l'-          find Nil            = error "findMin Nil"---- | \(O(\min(n,W))\). The maximal element of a set.-findMax :: Word64Set -> Key-findMax Nil = error "findMax: empty set has no maximal element"-findMax (Tip kx bm) = kx + highestBitSet bm-findMax (Bin _ m l r)-  |   m < 0   = find l-  | otherwise = find r-    where find (Tip kx bm) = kx + highestBitSet bm-          find (Bin _ _ _ r') = find r'-          find Nil            = error "findMax Nil"----- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.------ Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;--- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.-deleteMin :: Word64Set -> Word64Set-deleteMin = maybe Nil snd . minView---- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty.------ Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;--- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.-deleteMax :: Word64Set -> Word64Set-deleteMax = maybe Nil snd . maxView--{-----------------------------------------------------------------------  Map-----------------------------------------------------------------------}---- | \(O(n \min(n,W))\).--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.------ It's worth noting that the size of the result may be smaller if,--- for some @(x,y)@, @x \/= y && f x == f y@--map :: (Key -> Key) -> Word64Set -> Word64Set-map f = fromList . List.map f . toList---- | \(O(n)\). The------ @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- >                     ==> mapMonotonic f s == map f s--- >     where ls = toList s------ @since 0.6.3.1---- Note that for now the test is insufficient to support any fancier implementation.-mapMonotonic :: (Key -> Key) -> Word64Set -> Word64Set-mapMonotonic f = fromDistinctAscList . List.map f . toAscList---{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | \(O(n)\). Fold the elements in the set using the given right-associative--- binary operator. This function is an equivalent of 'foldr' and is present--- for compatibility only.------ /Please note that fold will be deprecated in the future and removed./-fold :: (Key -> b -> b) -> b -> Word64Set -> b-fold = foldr-{-# INLINE fold #-}---- | \(O(n)\). Fold the elements in the set using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.------ For example,------ > toAscList set = foldr (:) [] set-foldr :: (Key -> b -> b) -> b -> Word64Set -> b-foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before-                        | otherwise -> go (go z r) l-            _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx bm)   = foldrBits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr #-}---- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (Key -> b -> b) -> b -> Word64Set -> b-foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before-                        | otherwise -> go (go z r) l-            _ -> go z t-  where-    go !z' Nil           = z'-    go z' (Tip kx bm)   = foldr'Bits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr' #-}---- | \(O(n)\). Fold the elements in the set using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.------ For example,------ > toDescList set = foldl (flip (:)) [] set-foldl :: (a -> Key -> a) -> a -> Word64Set -> a-foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before-                        | otherwise -> go (go z l) r-            _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx bm)   = foldlBits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl #-}---- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> Key -> a) -> a -> Word64Set -> a-foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before-                        | otherwise -> go (go z l) r-            _ -> go z t-  where-    go !z' Nil           = z'-    go z' (Tip kx bm)   = foldl'Bits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl' #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.--- Subject to list fusion.-elems :: Word64Set -> [Key]-elems-  = toAscList--{---------------------------------------------------------------------  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]-toList-  = toAscList---- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list--- fusion.-toAscList :: Word64Set -> [Key]-toAscList = foldr (:) []---- | \(O(n)\). Convert the set to a descending list of elements. Subject to list--- fusion.-toDescList :: Word64Set -> [Key]-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-foldrFB = foldr-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> Key -> a) -> a -> Word64Set -> a-foldlFB = foldl-{-# INLINE[0] foldlFB #-}---- Inline elems and toList, so that we need to fuse only toAscList.-{-# INLINE elems #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded to{Asc,Desc}List calls back to--- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in--- a list fusion, otherwise it would go away in phase 1), and let compiler do--- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it--- before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "Word64Set.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}-{-# 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.-fromList :: [Key] -> Word64Set-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t x  = insert x t---- | \(O(n)\). Build a set from an ascending list of elements.--- /The precondition (input list is ascending) is not checked./-fromAscList :: [Key] -> Word64Set-fromAscList = fromMonoList-{-# NOINLINE fromAscList #-}---- | \(O(n)\). Build a set from an ascending list of distinct elements.--- /The precondition (input list is strictly ascending) is not checked./-fromDistinctAscList :: [Key] -> Word64Set-fromDistinctAscList = fromAscList-{-# INLINE fromDistinctAscList #-}---- | \(O(n)\). Build a set from a monotonic list of elements.------ The precise conditions under which this function works are subtle:--- For any branch mask, keys with the same prefix w.r.t. the branch--- mask must occur consecutively in the list.-fromMonoList :: [Key] -> Word64Set-fromMonoList []         = Nil-fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1-  where-    -- `addAll'` collects all keys with the prefix `px` into a single-    -- bitmap, and then proceeds with `addAll`.-    addAll' !px !bm []-        = Tip px bm-    addAll' !px !bm (ky : zs)-        | px == prefixOf ky-        = addAll' px (bm .|. bitmapOf ky) zs-        -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)-        | py <- prefixOf ky-        , m <- branchMask px py-        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs-        = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs'--    -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`-    -- `addAll` consumes the rest of the list, adding to the tree `tx`-    addAll !_px !tx []-        = tx-    addAll !px !tx (ky : zs)-        | py <- prefixOf ky-        , m <- branchMask px py-        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs-        = addAll px (linkWithMask m py ty {-px-} tx) zs'--    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.-    addMany' !_m !px !bm []-        = Inserted (Tip px bm) []-    addMany' !m !px !bm zs0@(ky : zs)-        | px == prefixOf ky-        = addMany' m px (bm .|. bitmapOf ky) zs-        -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)-        | mask px m /= mask ky m-        = Inserted (Tip (prefixOf px) bm) zs0-        | py <- prefixOf ky-        , mxy <- branchMask px py-        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs-        = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs'--    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.-    addMany !_m !_px tx []-        = Inserted tx []-    addMany !m !px tx zs0@(ky : zs)-        | mask px m /= mask ky m-        = Inserted tx zs0-        | py <- prefixOf ky-        , mxy <- branchMask px py-        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs-        = addMany m px (linkWithMask mxy py ty {-px-} tx) zs'-{-# INLINE fromMonoList #-}--data Inserted = Inserted !Word64Set ![Key]--{---------------------------------------------------------------------  Eq---------------------------------------------------------------------}-instance Eq Word64Set where-  t1 == t2  = equal t1 t2-  t1 /= t2  = nequal t1 t2--equal :: Word64Set -> Word64Set -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)-equal (Tip kx1 bm1) (Tip kx2 bm2)-  = kx1 == kx2 && bm1 == bm2-equal Nil Nil = True-equal _   _   = False--nequal :: Word64Set -> Word64Set -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip kx1 bm1) (Tip kx2 bm2)-  = kx1 /= kx2 || bm1 /= bm2-nequal Nil Nil = False-nequal _   _   = True--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord Word64Set where-    compare s1 s2 = compare (toAscList s1) (toAscList s2)-    -- tentative implementation. See if more efficient exists.--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show Word64Set where-  showsPrec p xs = showParen (p > 10) $-    showString "fromList " . shows (toList xs)--{---------------------------------------------------------------------  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---------------------------------------------------------------------}---- The Word64Set constructors consist only of strict fields of Ints and--- Word64Sets, thus the default NFData instance which evaluates to whnf--- should suffice-instance NFData Word64Set where rnf x = seq x ()--{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown--- in a compressed, hanging format.-showTree :: Word64Set -> String-showTree s-  = showTreeWith True False s---{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows- the tree that implements the set. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--}-showTreeWith :: Bool -> Bool -> Word64Set -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Bool -> [String] -> [String] -> Word64Set -> ShowS-showsTree wide lbars rbars t-  = case t of-      Bin p m l r-          -> showsTree wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . showString (showBin p m) . showString "\n" .-             showWide wide lbars .-             showsTree wide (withEmpty lbars) (withBar lbars) l-      Tip kx bm-          -> showsBars lbars . showString " " . shows kx . showString " + " .-                                                showsBitMap bm . showString "\n"-      Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Bool -> [String] -> Word64Set -> ShowS-showsTreeHang wide bars t-  = case t of-      Bin p m l r-          -> showsBars bars . showString (showBin p m) . showString "\n" .-             showWide wide bars .-             showsTreeHang wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang wide (withEmpty bars) r-      Tip kx bm-          -> showsBars bars . showString " " . shows kx . showString " + " .-                                               showsBitMap bm . showString "\n"-      Nil -> showsBars bars . showString "|\n"--showBin :: Prefix -> Mask -> String-showBin _ _-  = "*" -- ++ show (p,m)--showWide :: Bool -> [String] -> String -> String-showWide wide bars-  | wide      = showString (concat (reverse bars)) . showString "|\n"-  | otherwise = id--showsBars :: [String] -> ShowS-showsBars [] = id-showsBars (_ : tl) = showString (concat (reverse tl)) . showString node--showsBitMap :: Word64 -> ShowS-showsBitMap = showString . showBitMap--showBitMap :: Word64 -> String-showBitMap w = show $ foldrBits 0 (:) [] w--node :: String-node           = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars---{---------------------------------------------------------------------  Helpers---------------------------------------------------------------------}-{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: Prefix -> Word64Set -> Prefix -> Word64Set -> Word64Set-link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2-{-# INLINE link #-}---- `linkWithMask` is useful when the `branchMask` has already been computed-linkWithMask :: Mask -> Prefix -> Word64Set -> Word64Set -> Word64Set-linkWithMask m p1 t1 {-p2-} t2-  | zero p1 m = Bin p m t1 t2-  | otherwise = Bin p m t2 t1-  where-    p = mask p1 m-{-# INLINE linkWithMask #-}--{---------------------------------------------------------------------  @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> Word64Set -> Word64Set -> Word64Set-bin _ _ l Nil = l-bin _ _ Nil r = r-bin p m l r   = Bin p m l r-{-# INLINE bin #-}--{---------------------------------------------------------------------  @tip@ assures that we never have empty bitmaps within a tree.---------------------------------------------------------------------}-tip :: Prefix -> BitMap -> Word64Set-tip _ 0 = Nil-tip kx bm = Tip kx bm-{-# INLINE tip #-}---{-----------------------------------------------------------------------  Functions that generate Prefix and BitMap of a Key or a Suffix.-----------------------------------------------------------------------}--suffixBitMask :: Word64-suffixBitMask = fromIntegral (finiteBitSize (undefined::Word64)) - 1-{-# INLINE suffixBitMask #-}--prefixBitMask :: Word64-prefixBitMask = complement suffixBitMask-{-# INLINE prefixBitMask #-}--prefixOf :: Word64 -> Prefix-prefixOf x = x .&. prefixBitMask-{-# INLINE prefixOf #-}--suffixOf :: Word64 -> Word64-suffixOf x = x .&. suffixBitMask-{-# INLINE suffixOf #-}--bitmapOfSuffix :: Word64 -> BitMap-bitmapOfSuffix s = 1 `shiftLL` fromIntegral s-{-# INLINE bitmapOfSuffix #-}--bitmapOf :: Word64 -> BitMap-bitmapOf x = bitmapOfSuffix (suffixOf x)-{-# INLINE bitmapOf #-}---{---------------------------------------------------------------------  Endian independent bit twiddling---------------------------------------------------------------------}--- Returns True iff the bits set in i and the Mask m are disjoint.-zero :: Word64 -> Mask -> Bool-zero i m-  = (natFromInt i) .&. (natFromInt m) == 0-{-# INLINE zero #-}--nomatch,match :: Word64 -> Prefix -> Mask -> Bool-nomatch i p m-  = (mask i m) /= p-{-# INLINE nomatch #-}--match i p m-  = (mask i m) == p-{-# INLINE match #-}---- Suppose a is largest such that 2^a divides 2*m.--- Then mask i m is i with the low a bits zeroed out.-mask :: Word64 -> Mask -> Prefix-mask i m-  = maskW (natFromInt i) (natFromInt m)-{-# INLINE mask #-}--{---------------------------------------------------------------------  Big endian operations---------------------------------------------------------------------}-maskW :: Nat -> Nat -> Prefix-maskW i m-  = intFromNat (i .&. (complement (m-1) `xor` m))-{-# INLINE maskW #-}--shorter :: Mask -> Mask -> Bool-shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)-{-# INLINE shorter #-}--branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2-  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-{-# INLINE branchMask #-}--{-----------------------------------------------------------------------  To get best performance, we provide fast implementations of-  lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.-  If the intel bsf and bsr instructions ever become GHC primops,-  this code should be reimplemented using these.--  Performance of this code is crucial for folds, toList, filter, partition.--  The signatures of methods in question are placed after this comment.-----------------------------------------------------------------------}--lowestBitSet :: Nat -> Word64-highestBitSet :: Nat -> Word64-foldlBits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a-foldl'Bits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a-foldrBits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a-foldr'Bits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a-takeWhileAntitoneBits :: Word64 -> (Word64 -> Bool) -> Nat -> Nat--{-# INLINE lowestBitSet #-}-{-# INLINE highestBitSet #-}-{-# INLINE foldlBits #-}-{-# INLINE foldl'Bits #-}-{-# INLINE foldrBits #-}-{-# INLINE foldr'Bits #-}-{-# INLINE takeWhileAntitoneBits #-}--#if defined(__GLASGOW_HASKELL__)-indexOfTheOnlyBit :: Nat -> Word64-{-# INLINE indexOfTheOnlyBit #-}-indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask--lowestBitSet x = fromIntegral $ countTrailingZeros x--highestBitSet x = fromIntegral $ 63 - countLeadingZeros x--lowestBitMask :: Nat -> Nat-lowestBitMask x = x .&. negate x-{-# INLINE lowestBitMask #-}---- Reverse the order of bits in the Nat.-revNat :: Nat -> Nat-revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of-              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of-                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of-                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of-                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of-                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);--foldlBits prefix f z bitmap = go bitmap z-  where go 0 acc = acc-        go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))-          where-            !bitmask = lowestBitMask bm-            !bi = indexOfTheOnlyBit bitmask--foldl'Bits prefix f z bitmap = go bitmap z-  where go 0 acc = acc-        go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))-          where !bitmask = lowestBitMask bm-                !bi = indexOfTheOnlyBit bitmask--foldrBits prefix f z bitmap = go (revNat bitmap) z-  where go 0 acc = acc-        go bm acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)-          where !bitmask = lowestBitMask bm-                !bi = indexOfTheOnlyBit bitmask---foldr'Bits prefix f z bitmap = go (revNat bitmap) z-  where go 0 acc = acc-        go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)-          where !bitmask = lowestBitMask bm-                !bi = indexOfTheOnlyBit bitmask--takeWhileAntitoneBits prefix predicate bitmap =-  -- Binary search for the first index where the predicate returns false, but skip a predicate-  -- call if the high half of the current range is empty. This ensures-  -- min (log2 64 + 1 = 7) (popcount bitmap) predicate calls.-  let next d h (n',b') =-        if n' .&. h /= 0 && (predicate $! prefix + fromIntegral (b'+d)) then (n' `shiftRL` d, b'+d) else (n',b')-      {-# INLINE next #-}-      (_,b) = next 1  0x2 $-              next 2  0xC $-              next 4  0xF0 $-              next 8  0xFF00 $-              next 16 0xFFFF0000 $-              next 32 0xFFFFFFFF00000000 $-              (bitmap,0)-      m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)-          then ((2 `shiftLL` b) - 1)-          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---{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}---- | \(O(1)\).  Decompose a set into pieces based on the structure of the underlying--- tree.  This function is useful for consuming a set in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this.  However, it is guaranteed that the--- pieces returned will be in ascending order (all elements in the first submap--- less than all elements in the second, and so on).------ Examples:------ > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]--- > splitRoot empty == []------  Note that the current implementation does not return more than two subsets,---  but you should not depend on this behaviour because it can change in the---  future without notice. Also, the current version does not continue---  splitting all the way to individual singleton sets -- it stops at some---  point.-splitRoot :: Word64Set -> [Word64Set]-splitRoot Nil = []--- NOTE: we don't currently split below Tip, but we could.-splitRoot x@(Tip _ _) = [x]-splitRoot (Bin _ m l r) | m < 0 = [r, l]-                        | otherwise = [l, r]-{-# INLINE splitRoot #-}
compiler/GHC/Driver/Backend.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiWayIf, LambdaCase #-}  {-| Module      : GHC.Driver.Backend@@ -87,7 +87,7 @@    , backendUnregisterisedAbiOnly    , backendGeneratesHc    , backendSptIsDynamic-   , backendWantsBreakpointTicks+   , backendSupportsBreakpoints    , backendForcesOptimization0    , backendNeedsFullWays    , backendSpecialModuleSource@@ -551,17 +551,14 @@  -- | This back end wants the `mi_globals` 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@@ -691,16 +688,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
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,18 +25,18 @@ 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 ()+import GHC.Utils.Outputable (text)  import Data.Function import Data.List (sortBy, intercalate, stripPrefix)-import Data.Word  import GHC.ResponseFile import Control.Exception (IOException, catch)@@ -75,7 +75,7 @@       go (OptPrefix k) = OptPrefix (\s -> go2 (k s))       go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))       go (IntSuffix k) = IntSuffix (\n -> go2 (k n))-      go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s))+      go (WordSuffix k) = WordSuffix (\s -> go2 (k s))       go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))       go (PassFlag k) = PassFlag (\s -> go2 (k s))       go (AnySuffix k) = AnySuffix (\s -> go2 (k s))@@ -98,7 +98,7 @@     | OptPrefix (String -> EwM m ())       -- -f or -farg (i.e. the arg is optional)     | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn     | IntSuffix (Int -> EwM m ())          -- -f or -f=n; pass n to fn-    | Word64Suffix (Word64 -> EwM m ())    -- -f or -f=n; pass n to fn+    | WordSuffix (Word -> EwM m ())        -- -f or -f=n; pass n to fn     | FloatSuffix (Float -> EwM m ())      -- -f or -f=n; pass n to fn     | PassFlag  (String -> EwM m ())       -- -f; pass "-f" fn     | AnySuffix (String -> EwM m ())       -- -f or -farg; pass entire "-farg" to fn@@ -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 [] @@ -251,7 +240,7 @@         IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)                     | otherwise -> Left ("malformed integer argument in " ++ dash_arg) -        Word64Suffix f | Just n <- parseWord64 rest_no_eq -> Right (f n, args)+        WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)                      | otherwise -> Left ("malformed natural argument in " ++ dash_arg)          FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)@@ -280,7 +269,7 @@                                             -- to improve error message (#12625) arg_ok (OptIntSuffix    _)  _    _   = True arg_ok (IntSuffix       _)  _    _   = True-arg_ok (Word64Suffix    _)  _    _   = True+arg_ok (WordSuffix      _)  _    _   = True arg_ok (FloatSuffix     _)  _    _   = True arg_ok (OptPrefix       _)  _    _   = True arg_ok (PassFlag        _)  rest _   = null rest@@ -296,8 +285,8 @@                  ((n,""):_) -> Just n                  _          -> Nothing -parseWord64 :: String -> Maybe Word64-parseWord64 s = case reads s of+parseWord :: String -> Maybe Word+parseWord s = case reads s of                  ((n,""):_) -> Just n                  _          -> Nothing
compiler/GHC/Driver/Config.hs view
@@ -2,22 +2,17 @@ module GHC.Driver.Config    ( initOptCoercionOpts    , initSimpleOpts-   , initBCOOpts    , initEvalOpts    ) 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@@ -31,16 +26,6 @@    , so_co_opts = initOptCoercionOpts dflags    , so_eta_red = gopt Opt_DoEtaReduction dflags    }---- | 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  -- | Extract GHCi options from DynFlags and step initEvalOpts :: DynFlags -> Bool -> EvalOpts
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 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
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.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage) import GHC.Driver.Errors.Ppr () 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
+ compiler/GHC/Driver/DynFlags.hs view
@@ -0,0 +1,1539 @@+{-# 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,++        -- ** 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,++        -- * Linker/compiler information+        LinkerInfo(..),+        CompilerInfo(..),++        -- * 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.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.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.IORef+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,+  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+  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     :: 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,+  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,++  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.+  fma                   :: Bool, -- ^ Enable FMA 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         :: Word,+  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+ 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            = 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       = 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,+        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,++        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,+        fma = 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++++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 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++-- -----------------------------------------------------------------------------+-- Linker/compiler information++-- LinkerInfo contains any extra options needed by the system linker.+data LinkerInfo+  = GnuLD    [Option]+  | Mold     [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++-- | 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++-- | 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.+ -}++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_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+    ]++    ++ [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)+    , ([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)+    , ([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+    ]++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++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.+    _                      -> []++-- | 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]+++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++-- 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+  , 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+  }
compiler/GHC/Driver/Env.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-}  module GHC.Driver.Env    ( Hsc(..)@@ -42,7 +41,7 @@  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)@@ -84,10 +83,7 @@  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@@ -267,35 +263,6 @@ 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--    -- 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--- -- | Get things from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]@@ -304,11 +271,12 @@    | otherwise   = 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)+      (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@@ -324,7 +292,7 @@                     Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" 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@@ -359,20 +327,23 @@ lookupType hsc_env name = do    eps <- liftIO $ hscEPS hsc_env    let pte = eps_PTE eps-       hpt = hsc_HUG hsc_env+   return $ 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 -> 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 lookupNameEnv pte name+            else case lookupHugByModule mod hpt of+             Just hm -> lookupNameEnv (md_types (hm_details hm)) name+             Nothing -> lookupNameEnv pte name  -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information
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
compiler/GHC/Driver/Errors.hs view
@@ -2,54 +2,38 @@ 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 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)+                in logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $+                   updSDocContext (\_ -> ctx) (messageWithHints dia)               | 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 :: Diagnostic a => 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)  -- | 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,10 +13,9 @@  import GHC.Driver.Errors.Types import GHC.Driver.Flags-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.HsToCore.Errors.Ppr () import GHC.Parser.Errors.Ppr ()-import GHC.Tc.Errors.Ppr () import GHC.Types.Error import GHC.Types.Error.Codes ( constructorCode ) import GHC.Unit.Types@@ -30,6 +29,9 @@ 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 ()+import GHC.Iface.Errors.Ppr ()  -- -- Suggestions@@ -40,12 +42,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 +59,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@@ -84,12 +88,14 @@    diagnosticCode = constructorCode +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@@ -218,7 +224,21 @@       -> 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+   diagnosticReason = \case     DriverUnknownMessage m       -> diagnosticReason m@@ -272,6 +292,17 @@       -> ErrorWithoutFlag     DriverHomePackagesNotClosed {}       -> ErrorWithoutFlag+    DriverInterfaceError reason -> diagnosticReason reason+    DriverInconsistentDynFlags {}+      -> WarningWithFlag Opt_WarnInconsistentFlags+    DriverSafeHaskellIgnoredExtension {}+      -> WarningWithoutFlag+    DriverPackageTrustIgnored {}+      -> WarningWithoutFlag+    DriverUnrecognisedFlag {}+      -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags+    DriverDeprecatedFlag {}+      -> WarningWithFlag Opt_WarnDeprecatedFlags    diagnosticHints = \case     DriverUnknownMessage m@@ -327,6 +358,17 @@     DriverRedirectedNoMain {}       -> noHints     DriverHomePackagesNotClosed {}+      -> noHints+    DriverInterfaceError reason -> diagnosticHints reason+    DriverInconsistentDynFlags {}+      -> noHints+    DriverSafeHaskellIgnoredExtension {}+      -> noHints+    DriverPackageTrustIgnored {}+      -> noHints+    DriverUnrecognisedFlag {}+      -> noHints+    DriverDeprecatedFlag {}       -> noHints    diagnosticCode = constructorCode
compiler/GHC/Driver/Errors/Types.hs view
@@ -8,7 +8,6 @@   , DriverMessage(..)   , DriverMessageOpts(..)   , DriverMessages, PsMessage(PsHeaderMessage)-  , BuildingCabalPackage(..)   , WarningMessages   , ErrorMessages   , WarnMsg@@ -25,20 +24,24 @@ import Data.Bifunctor import Data.Typeable -import GHC.Driver.Session+import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt)+import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage)) import GHC.Types.Error import GHC.Unit.Module 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,7 +93,7 @@   -- '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 :: (UnknownDiagnostic (DiagnosticOpts GhcMessage)) -> GhcMessage    deriving Generic @@ -108,7 +111,7 @@ -- 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 = GhcUnknownMessage . mkSimpleUnknownDiagnostic  -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'.@@ -126,7 +129,7 @@ -- | A message from the driver. data DriverMessage where   -- | Simply wraps a generic 'Diagnostic' message @a@.-  DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage+  DriverUnknownMessage :: UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage    -- | A parse error in parsing a Haskell file header during dependency   -- analysis@@ -368,17 +371,25 @@    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+ 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
@@ -8,11 +8,17 @@    , codeGenFlags     -- * Warnings+   , WarningGroup(..)+   , warningGroupName+   , warningGroupFlags+   , warningGroupIncludesExtendedWarnings    , WarningFlag(..)    , warnFlagNames    , warningGroups    , warningHierarchies    , smallestWarningGroups+   , smallestWarningGroupsForCategory+    , standardWarnings    , minusWOpts    , minusWallOpts@@ -47,7 +53,7 @@  -- | 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@@ -102,6 +108,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)@@ -121,6 +128,10 @@    | 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@@ -150,7 +161,6 @@    | Opt_D_no_debug_output    | Opt_D_dump_faststrings    | Opt_D_faststring_stats-   | Opt_D_ipe_stats    deriving (Eq, Show, Enum)  -- | Helper function to query whether a given `DumpFlag` is enabled or not.@@ -195,7 +205,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>@@ -213,8 +223,6 @@     | Opt_DistinctConstructorTables    | Opt_InfoTableMap-   | Opt_InfoTableMapWithFallback-   | Opt_InfoTableMapWithStack     | Opt_WarnIsError                    -- -Werror; makes warnings fatal    | Opt_ShowWarnGroups                 -- Show the group a warning belongs to@@ -260,6 +268,7 @@    | Opt_LiberateCase    | Opt_SpecConstr    | Opt_SpecConstrKeen+   | Opt_SpecialiseIncoherents    | Opt_DoLambdaEtaExpansion    | Opt_IgnoreAsserts    | Opt_DoEtaReduction@@ -298,10 +307,7 @@    | Opt_NumConstantFolding    | Opt_CoreConstantFolding    | Opt_FastPAPCalls                  -- #6084-   | Opt_SpecEval-   | Opt_SpecEvalDictFun   -- See Note [Controlling Speculative Evaluation] -    -- Inference flags    | Opt_DoTagInferenceChecks @@ -316,6 +322,9 @@    | Opt_WriteInterface -- forces .hi files to be written even with -fno-code    | Opt_WriteHie -- generate .hie files +   -- JavaScript opts+   | Opt_DisableJsMinifier -- ^ render JavaScript pretty-printed instead of minified (compacted)+    -- profiling opts    | Opt_AutoSccsOnIndividualCafs    | Opt_ProfCountEntries@@ -348,6 +357,7 @@    | Opt_BuildingCabalPackage    | Opt_IgnoreDotGhci    | Opt_GhciSandbox+   | Opt_InsertBreakpoints    | Opt_GhciHistory    | Opt_GhciLeakCheck    | Opt_ValidateHie@@ -389,6 +399,7 @@    | Opt_KeepGoing    | Opt_ByteCode    | Opt_ByteCodeAndObjectCode+   | Opt_UnoptimizedCoreForInterpreter    | Opt_LinkRts     -- output style opts@@ -525,8 +536,6 @@    , Opt_WorkerWrapper    , Opt_WorkerWrapperUnlift    , Opt_SolveConstantDicts-   , Opt_SpecEval-   , Opt_SpecEvalDictFun    ]  -- | The set of flags which affect code generation and can change a program's@@ -568,12 +577,10 @@      -- Flags that affect debugging information    , Opt_DistinctConstructorTables    , Opt_InfoTableMap-   , Opt_InfoTableMapWithStack-   , Opt_InfoTableMapWithFallback    ]  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,7 +610,6 @@    | 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@@ -664,6 +670,7 @@    | 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@@ -672,7 +679,12 @@    | Opt_WarnTypeEqualityOutOfScope                  -- Since 9.4    | Opt_WarnTypeEqualityRequiresOperators           -- Since 9.4    | Opt_WarnLoopySuperclassSolve                    -- Since 9.6-   deriving (Eq, Ord, Show, Enum, Bounded)+   | Opt_WarnTermVariableCapture                     -- Since 9.8+   | Opt_WarnMissingRoleAnnotations                  -- Since 9.8+   | Opt_WarnImplicitRhsQuantification               -- Since 9.8+   | Opt_WarnIncompleteExportWarnings                -- Since 9.8+   | Opt_WarnInconsistentFlags                       -- Since 9.8+   deriving (Eq, Ord, Show, Enum)  -- | Return the names of a WarningFlag --@@ -683,11 +695,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 +728,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 +791,10 @@   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_WarnInconsistentFlags                       -> "inconsistent-flags" :| []  -- ----------------------------------------------------------------------------- -- Standard sets of warning options@@ -785,24 +802,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 -- 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.@@ -815,31 +870,34 @@ -- hierarchies with no inherent relation to be defined. -- -- The special-case Weverything group is not included.-warningHierarchies :: [[String]]+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,@@ -875,7 +933,8 @@         Opt_WarnUnicodeBidirectionalFormatCharacters,         Opt_WarnGADTMonoLocalBinds,         Opt_WarnLoopySuperclassSolve,-        Opt_WarnTypeEqualityRequiresOperators+        Opt_WarnTypeEqualityRequiresOperators,+        Opt_WarnInconsistentFlags       ]  -- | Things you get with -W@@ -909,7 +968,8 @@         Opt_WarnUnusedRecordWildcards,         Opt_WarnRedundantRecordWildcards,         Opt_WarnIncompleteUniPatterns,-        Opt_WarnIncompletePatternsRecUpd+        Opt_WarnIncompletePatternsRecUpd,+        Opt_WarnIncompleteExportWarnings       ]  -- | Things you get with -Weverything, i.e. *all* known warnings flags@@ -925,8 +985,10 @@ minusWcompatOpts     = [ Opt_WarnSemigroup       , Opt_WarnNonCanonicalMonoidInstances+      , Opt_WarnNonCanonicalMonadInstances       , Opt_WarnCompatUnqualifiedImports       , Opt_WarnTypeEqualityOutOfScope+      , Opt_WarnImplicitRhsQuantification       ]  -- | Things you get with -Wunused-binds
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@@ -121,6 +121,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]
compiler/GHC/Driver/Monad.hs view
@@ -34,7 +34,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
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)
compiler/GHC/Driver/Plugins.hs view
@@ -82,7 +82,7 @@  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 )
compiler/GHC/Driver/Ppr.hs view
@@ -11,7 +11,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Unit.State  import GHC.Utils.Outputable
compiler/GHC/Driver/Session.hs view
@@ -34,5056 +34,3817 @@         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+        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,++        -- ** 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,+        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+        isSse4_2Enabled,+        isBmiEnabled,+        isBmi2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,++        -- * 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.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.Panic+import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.GlobalVars+import GHC.Data.Maybe+import GHC.Data.Bool+import GHC.Types.Error+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.Settings+import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Opt.CallerCC++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 qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Set as Set+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+  , 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_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++-----------------------------------------------------------------------------++{-+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, 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], 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 => 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?+    -> DynFlags                      -- ^ current dynamic flags+    -> [Located String]              -- ^ arguments to parse+    -> m (DynFlags, [Located String], Messages DriverMessage)+parseDynamicFlagsFull activeFlags cmdline 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) = 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]++  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)+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 (WordSuffix f) message =+                                  WordSuffix $ \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 "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-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-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-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 "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 }))+  , 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_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 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"+      (wordSuffix (\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)+  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"+      (NoArg (setGeneralFlag Opt_DistinctConstructorTables))+  , make_ord_flag defGhcFlag "finfo-table-map"+      (NoArg (setGeneralFlag Opt_InfoTableMap))+        ------ 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))+    ]++     ------ 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)+  ]+  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 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)++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 = mconcat [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  warnSpec    Opt_WarnAlternativeLayoutRuleTransitional,+  warnSpec    Opt_WarnAmbiguousFields,+  depWarnSpec Opt_WarnAutoOrphans+              "it has no effect",+  warnSpec    Opt_WarnCPPUndef,+  warnSpec    Opt_WarnUnbangedStrictPatterns,+  warnSpec    Opt_WarnDeferredTypeErrors,+  warnSpec    Opt_WarnDeferredOutOfScopeVariables,+  warnSpec    Opt_WarnDeprecatedFlags,+  warnSpec    Opt_WarnDerivingDefaults,+  warnSpec    Opt_WarnDerivingTypeable,+  warnSpec    Opt_WarnDodgyExports,+  warnSpec    Opt_WarnDodgyForeignImports,+  warnSpec    Opt_WarnDodgyImports,+  warnSpec    Opt_WarnEmptyEnumerations,+  subWarnSpec "duplicate-constraints"+              Opt_WarnDuplicateConstraints+              "it is subsumed by -Wredundant-constraints",+  warnSpec    Opt_WarnRedundantConstraints,+  warnSpec    Opt_WarnDuplicateExports,+  depWarnSpec Opt_WarnHiShadows+              "it is not used, and was never implemented",+  warnSpec    Opt_WarnInaccessibleCode,+  warnSpec    Opt_WarnImplicitPrelude,+  depWarnSpec Opt_WarnImplicitKindVars+              "it is now an error",+  warnSpec    Opt_WarnIncompletePatterns,+  warnSpec    Opt_WarnIncompletePatternsRecUpd,+  warnSpec    Opt_WarnIncompleteUniPatterns,+  warnSpec    Opt_WarnInlineRuleShadowing,+  warnSpec    Opt_WarnIdentities,+  warnSpec    Opt_WarnMissingFields,+  warnSpec    Opt_WarnMissingImportList,+  warnSpec    Opt_WarnMissingExportList,+  subWarnSpec "missing-local-sigs"+              Opt_WarnMissingLocalSignatures+              "it is replaced by -Wmissing-local-signatures",+  warnSpec    Opt_WarnMissingLocalSignatures,+  warnSpec    Opt_WarnMissingMethods,+  depWarnSpec Opt_WarnMissingMonadFailInstances+              "fail is no longer a method of Monad",+  warnSpec    Opt_WarnSemigroup,+  warnSpec    Opt_WarnMissingSignatures,+  warnSpec    Opt_WarnMissingKindSignatures,+  warnSpec    Opt_WarnMissingPolyKindSignatures,+  subWarnSpec "missing-exported-sigs"+              Opt_WarnMissingExportedSignatures+              "it is replaced by -Wmissing-exported-signatures",+  warnSpec    Opt_WarnMissingExportedSignatures,+  warnSpec    Opt_WarnMonomorphism,+  warnSpec    Opt_WarnNameShadowing,+  warnSpec    Opt_WarnNonCanonicalMonadInstances,+  depWarnSpec Opt_WarnNonCanonicalMonadFailInstances+              "fail is no longer a method of Monad",+  warnSpec    Opt_WarnNonCanonicalMonoidInstances,+  warnSpec    Opt_WarnOrphans,+  warnSpec    Opt_WarnOverflowedLiterals,+  warnSpec    Opt_WarnOverlappingPatterns,+  warnSpec    Opt_WarnMissedSpecs,+  warnSpec    Opt_WarnAllMissedSpecs,+  warnSpec'   Opt_WarnSafe setWarnSafe,+  warnSpec    Opt_WarnTrustworthySafe,+  warnSpec    Opt_WarnInferredSafeImports,+  warnSpec    Opt_WarnMissingSafeHaskellMode,+  warnSpec    Opt_WarnTabs,+  warnSpec    Opt_WarnTypeDefaults,+  warnSpec    Opt_WarnTypedHoles,+  warnSpec    Opt_WarnPartialTypeSignatures,+  warnSpec    Opt_WarnUnrecognisedPragmas,+  warnSpec    Opt_WarnMisplacedPragmas,+  warnSpec'   Opt_WarnUnsafe setWarnUnsafe,+  warnSpec    Opt_WarnUnsupportedCallingConventions,+  warnSpec    Opt_WarnUnsupportedLlvmVersion,+  warnSpec    Opt_WarnMissedExtraSharedLib,+  warnSpec    Opt_WarnUntickedPromotedConstructors,+  warnSpec    Opt_WarnUnusedDoBind,+  warnSpec    Opt_WarnUnusedForalls,+  warnSpec    Opt_WarnUnusedImports,+  warnSpec    Opt_WarnUnusedLocalBinds,+  warnSpec    Opt_WarnUnusedMatches,+  warnSpec    Opt_WarnUnusedPatternBinds,+  warnSpec    Opt_WarnUnusedTopBinds,+  warnSpec    Opt_WarnUnusedTypePatterns,+  warnSpec    Opt_WarnUnusedRecordWildcards,+  warnSpec    Opt_WarnRedundantBangPatterns,+  warnSpec    Opt_WarnRedundantRecordWildcards,+  warnSpec    Opt_WarnRedundantStrictnessFlags,+  warnSpec    Opt_WarnWrongDoBind,+  warnSpec    Opt_WarnMissingPatternSynonymSignatures,+  warnSpec    Opt_WarnMissingDerivingStrategies,+  warnSpec    Opt_WarnSimplifiableClassConstraints,+  warnSpec    Opt_WarnMissingHomeModules,+  warnSpec    Opt_WarnUnrecognisedWarningFlags,+  warnSpec    Opt_WarnStarBinder,+  warnSpec    Opt_WarnStarIsType,+  depWarnSpec Opt_WarnSpaceAfterBang+              "bang patterns can no longer be written with a space",+  warnSpec    Opt_WarnPartialFields,+  warnSpec    Opt_WarnPrepositiveQualifiedModule,+  warnSpec    Opt_WarnUnusedPackages,+  warnSpec    Opt_WarnCompatUnqualifiedImports,+  warnSpec    Opt_WarnInvalidHaddock,+  warnSpec    Opt_WarnOperatorWhitespaceExtConflict,+  warnSpec    Opt_WarnOperatorWhitespace,+  warnSpec    Opt_WarnImplicitLift,+  warnSpec    Opt_WarnMissingExportedPatternSynonymSignatures,+  warnSpec    Opt_WarnForallIdentifier,+  warnSpec    Opt_WarnUnicodeBidirectionalFormatCharacters,+  warnSpec    Opt_WarnGADTMonoLocalBinds,+  warnSpec    Opt_WarnTypeEqualityOutOfScope,+  warnSpec    Opt_WarnTypeEqualityRequiresOperators,+  warnSpec    Opt_WarnTermVariableCapture,+  warnSpec    Opt_WarnMissingRoleAnnotations,+  warnSpec    Opt_WarnImplicitRhsQuantification,+  warnSpec    Opt_WarnIncompleteExportWarnings+ ]++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,+  -- 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 "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-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 "num-constant-folding"             Opt_NumConstantFolding,+  flagSpec "core-constant-folding"            Opt_CoreConstantFolding,+  flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,+  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 "break-points"                     Opt_InsertBreakpoints+  ]+  ++ 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 backend+      | notJS, flagSpecFlag flg == LangExt.JavaScriptFFI    = [noName]+      | otherwise = [name, noName]+      where+        isAIX = os == OSAIX+        notJS = arch /= ArchJavaScript+        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 "ExtendedLiterals"                 LangExt.ExtendedLiterals,+  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 "TypeAbstractions"                 LangExt.TypeAbstractions,+  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+  ]++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)+                ] ++ 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)+  ]++++-- | 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))++wordSuffix :: (Word -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+wordSuffix fn = WordSuffix (\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 = [ 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++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),+       ("Project Unit Id",             cProjectUnitId),+       ("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 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),+       -- 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++{- -----------------------------------------------------------------------------+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, [Warn])+-- 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"++ | LinkMergedObj <- ghcLink dflags+ , Nothing <- outputFile dflags+ = pgmError "--output must be specified when using --merge-objs"++ | otherwise = (dflags, mempty)+    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")+          loop updated_dflags warning+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws)+          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, AVX, FMA++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++-- -----------------------------------------------------------------------------++-- | 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++-- | 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 ()++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
@@ -102,7 +102,8 @@ data AnnsModule   = AnnsModule {     am_main :: [AddEpAnn],-    am_decls :: AnnList+    am_decls :: [TrailingAnn],+    am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- End of file and end of prior token     } deriving (Data, Eq)  instance Outputable (HsModule GhcPs) where
compiler/GHC/Hs/Binds.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -120,7 +121,11 @@     , ( [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@@ -680,7 +685,7 @@ 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+    -- SourceText: Note [Pragma source text] in "GHC.Types.SourceText" type instance XXSig             GhcPs = DataConCantHappen type instance XXSig             GhcRn = IdSig type instance XXSig             GhcTc = IdSig@@ -756,7 +761,7 @@   = 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)@@ -828,7 +833,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
compiler/GHC/Hs/Decls.hs view
@@ -124,8 +124,8 @@ 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 (WarningTxt(..))  import GHC.Data.Bag import GHC.Data.Maybe@@ -703,7 +703,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@@ -911,9 +911,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,7 +935,7 @@     do_one (L _ (TyFamInstD {}))                              = []  -- | Convert a 'NewOrData' to a 'TyConFlavour'-newOrDataToFlavour :: NewOrData -> TyConFlavour+newOrDataToFlavour :: NewOrData -> TyConFlavour tc newOrDataToFlavour NewType  = NewtypeFlavour newOrDataToFlavour DataType = DataTypeFlavour @@ -1219,7 +1220,7 @@ 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@@ -1229,8 +1230,13 @@ instance OutputableBndrId p        => Outputable (WarnDecl (GhcPass p)) where     ppr (Warning _ thing txt)-      = hsep ( punctuate comma (map ppr thing))+      = ppr_category+              <+> hsep (punctuate comma (map ppr thing))               <+> ppr txt+      where+        ppr_category = case txt of+                         WarningTxt (Just cat) _ _ -> ppr cat+                         _ -> empty  {- ************************************************************************
compiler/GHC/Hs/Doc.hs view
@@ -123,7 +123,7 @@ data DocStructureItem   = DsiSectionHeading !Int !(HsDoc GhcRn)   | DsiDocChunk !(HsDoc GhcRn)-  | DsiNamedChunkRef !(String)+  | DsiNamedChunkRef !String   | DsiExports !Avails   | DsiModExport       !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple@@ -224,8 +224,8 @@ 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_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)
compiler/GHC/Hs/Dump.hs view
@@ -139,8 +139,8 @@             sourceText :: SourceText -> SDoc             sourceText NoSourceText = parens $ text "NoSourceText"             sourceText (SourceText src) = case bs of-              NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src-              BlankSrcSpanFile -> parens $ text "SourceText" <+> text src+              NoBlankSrcSpan   -> parens $ text "SourceText" <+> ftext src+              BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src               _                -> parens $ text "SourceText" <+> text "blanked"              epaAnchor :: EpaLocation -> SDoc
compiler/GHC/Hs/Expr.hs view
@@ -44,6 +44,7 @@  -- 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@@ -52,7 +53,8 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Tickish (CoreTickish)-import GHC.Core.ConLike+import GHC.Types.Unique.Set (UniqSet)+import GHC.Core.ConLike ( conLikeName, ConLike ) import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc import GHC.Utils.Outputable@@ -62,7 +64,7 @@ import GHC.Core.Type import GHC.Builtin.Types (mkTupleStr) import GHC.Tc.Utils.TcType (TcType, TcTyVar)-import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)+import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)  import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q)@@ -74,6 +76,7 @@ import Data.Maybe (isJust) import Data.Foldable ( toList ) import Data.List (uncons)+import Data.List.NonEmpty (NonEmpty) import Data.Bifunctor (first)  {- *********************************************************************@@ -128,7 +131,7 @@ -- | 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"))+noExpr = HsLit noComments (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))  noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)                               -- Before renaming, and sometimes after@@ -283,8 +286,8 @@ type instance XExplicitSum   GhcTc = [Type]  type instance XCase          GhcPs = EpAnn EpAnnHsCase-type instance XCase          GhcRn = NoExtField-type instance XCase          GhcTc = NoExtField+type instance XCase          GhcRn = HsMatchContext GhcTc+type instance XCase          GhcTc = HsMatchContext GhcTc  type instance XIf            GhcPs = EpAnn AnnsIf type instance XIf            GhcRn = NoExtField@@ -324,6 +327,31 @@   -- 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 = EpAnnCO type instance XGetField     GhcRn = NoExtField type instance XGetField     GhcTc = DataConCantHappen@@ -491,7 +519,7 @@ ppr_expr (HsIPVar _ v)       = ppr v ppr_expr (HsOverLabel _ s l) = char '#' <> case s of                                              NoSourceText -> ppr l-                                             SourceText src -> text src+                                             SourceText src -> ftext src ppr_expr (HsLit _ lit)       = ppr lit ppr_expr (HsOverLit _ lit)   = ppr lit ppr_expr (HsPar _ _ e _)     = parens (ppr_lexpr e)@@ -625,8 +653,10 @@  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))))+      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@@ -863,12 +893,14 @@   | GhcTc <- ghcPass @p          = go_x_tc x   | GhcRn <- ghcPass @p          = go_x_rn x   where+    go_x_tc :: XXExprGhcTc -> Bool     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 :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool     go_x_rn (HsExpanded a _) = isAtomicHsExpr a  isAtomicHsExpr _ = False@@ -1941,7 +1973,7 @@ 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 PatSyn                        = text "pattern synonym" matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"@@ -1998,11 +2030,10 @@ matchSeparator PatBindRhs       = text "=" matchSeparator PatBindGuards    = text "=" matchSeparator StmtCtxt{}       = text "<-"-matchSeparator RecUpd           = text "=" -- This can be printed by the pattern-                                       -- match checker trace+matchSeparator RecUpd           = text "="  -- This can be printed by the pattern+matchSeparator PatSyn           = text "<-" -- 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@@ -2023,7 +2054,7 @@ pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant                                               <+> text "alternative" pprMatchContextNoun IfAlt                   = text "multi-way if alternative"-pprMatchContextNoun RecUpd                  = text "record-update construct"+pprMatchContextNoun RecUpd                  = text "record update" pprMatchContextNoun ThPatSplice             = text "Template Haskell pattern splice" pprMatchContextNoun ThPatQuote              = text "Template Haskell pattern quotation" pprMatchContextNoun PatBindRhs              = text "pattern binding"
compiler/GHC/Hs/ImpExp.hs view
@@ -21,25 +21,28 @@     , 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 (WarningTxt)+ import Data.Data import Data.Maybe -import Language.Haskell.Syntax.Extension-import Language.Haskell.Syntax.Module.Name-import Language.Haskell.Syntax.ImpExp  {- ************************************************************************@@ -77,7 +80,7 @@ type instance XCImportDecl  GhcPs = XImportDeclPass type instance XCImportDecl  GhcRn = XImportDeclPass type instance XCImportDecl  GhcTc = DataConCantHappen-                                 -- Note [Pragma source text] in GHC.Types.SourceText+                                 -- Note [Pragma source text] in "GHC.Types.SourceText"  data XImportDeclPass = XImportDeclPass     { ideclAnn        :: EpAnn EpAnnImportDecl@@ -170,7 +173,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@@ -197,20 +200,39 @@  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 (LocatedP (WarningTxt GhcPs))+type instance XIEVar       GhcRn = Maybe (LocatedP (WarningTxt 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 (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])+type instance XIEThingAbs  GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])+type instance XIEThingAbs  GhcTc = EpAnn [AddEpAnn] --- 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 (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])+type instance XIEThingAll  GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])+type instance XIEThingAll  GhcTc = EpAnn [AddEpAnn] -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 (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])+type instance XIEThingWith GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])+type instance XIEThingWith GhcTc = 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 XIEModuleContents  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])+type instance XIEModuleContents  GhcRn = Maybe (LocatedP (WarningTxt GhcRn)) type instance XIEModuleContents  GhcTc = NoExtField  type instance XIEGroup           (GhcPass _) = NoExtField@@ -220,32 +242,6 @@  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.--}- ieName :: IE (GhcPass p) -> IdP (GhcPass p) ieName (IEVar _ (L _ n))            = ieWrappedName n ieName (IEThingAbs  _ (L _ n))      = ieWrappedName n@@ -265,6 +261,22 @@ 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 (LocatedP (WarningTxt (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 (IEName    _ (L l n)) = L l n ieWrappedLName (IEPattern _ (L l n)) = L l n@@ -289,12 +301,11 @@ replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')  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) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc var)]+    ppr ie@(IEThingAbs  _   thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing)]+    ppr ie@(IEThingAll  _   thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ hcat [ppr (unLoc thing), text "(..)"]]+    ppr ie@(IEThingWith _ thing wc withs)+        = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))]       where         ppWiths =           case wc of@@ -303,12 +314,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 ++ ">")
compiler/GHC/Hs/Instances.hs view
@@ -287,6 +287,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)@@ -450,6 +458,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)@@ -510,10 +523,10 @@ deriving instance Data thing => Data (HsScaled GhcRn thing) deriving instance Data thing => Data (HsScaled GhcTc thing) -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 (Data a, Data b) => Data (HsArg p a b)+deriving instance (Data a, Data b) => Data (HsArg GhcPs a b)+deriving instance (Data a, Data b) => Data (HsArg GhcRn a b)+deriving instance (Data a, Data b) => Data (HsArg GhcTc a b)  -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs)
compiler/GHC/Hs/Lit.hs view
@@ -50,7 +50,13 @@ 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@@ -128,14 +134,20 @@     go (HsString {})      = False     go (HsStringPrim {})  = False     go (HsInt _ x)        = p > topPrec && il_neg x-    go (HsIntPrim {})     = False-    go (HsWordPrim {})    = False-    go (HsInt64Prim {})   = 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 (HsIntPrim {})     = 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 (HsWord32Prim {})  = False     go (XLit _)           = False  -- | Convert a literal from one index type to another@@ -147,7 +159,13 @@ 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@@ -182,8 +200,14 @@     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)  -- in debug mode, print the expression that it's resolved to, too@@ -211,7 +235,13 @@ 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
compiler/GHC/Hs/Pat.hs view
@@ -43,7 +43,7 @@         looksLazyPatBind,         isBangedLPat,         gParPat, patNeedsParens, parenthesizePat,-        isIrrefutableHsPat,+        isIrrefutableHsPat, isBoringHsPat,          collectEvVarsPat, collectEvVarsPats, @@ -82,8 +82,6 @@ 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 Data.Data  @@ -244,8 +242,8 @@ hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) q -> Located RdrName+hsRecUpdFieldRdr = fmap ambiguousFieldOccRdrName . reLoc . hfbLHS  hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc@@ -502,22 +500,6 @@ 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]@@ -544,12 +526,23 @@  See also Note [decideBangHood] in GHC.HsToCore.Utils. -}--isIrrefutableHsPat' :: forall p. (OutputableBndrId p)+-- | (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 :: 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 is_strict = goL   where     goL :: LPat (GhcPass p) -> Bool     goL = go . unLoc@@ -559,7 +552,7 @@     go (VarPat {})         = True     go (LazyPat _ p')       | is_strict-      = isIrrefutableHsPat' False p'+      = isIrrefutableHsPat False p'       | otherwise          = True     go (BangPat _ pat)     = goL pat     go (ParPat _ _ pat _)  = goL pat@@ -616,7 +609,56 @@   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-dinstance 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 +    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+      LitPat {}     -> True+      NPat {}       -> True+      NPlusKPat {}  -> True+      SplicePat {}  -> False+      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+ {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as@@ -637,6 +679,58 @@ 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. -}  -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
compiler/GHC/Hs/Type.hs view
@@ -1,5 +1,6 @@  {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -31,6 +32,7 @@          HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,         HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,+        HsBndrVis(..), isHsBndrInvisible,         LHsQTyVars(..),         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,         HsWildCardBndrs(..),@@ -55,9 +57,12 @@          FieldOcc(..), LFieldOcc, mkFieldOcc,         AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,-        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,+        ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName,+        selectorAmbiguousFieldOcc,         unambiguousFieldOcc, ambiguousFieldOcc, +        OpName(..),+         mkAnonWildCardTy, pprAnonWildCard,          hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,@@ -68,7 +73,7 @@         mkHsForAllVisTele, mkHsForAllInvisTele,         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,         isHsKindedTyVar, hsTvbAllKinded,-        hsScopedTvs, hsWcScopedTvs, dropWildCards,+        hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,@@ -79,7 +84,7 @@         mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,         ignoreParens, hsSigWcType, hsPatSigType,         hsTyKindSig,-        setHsTyVarBndrFlag, hsTyVarBndrFlag,+        setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag,          -- Printing         pprHsType, pprHsForAll,@@ -94,6 +99,7 @@  import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension@@ -102,10 +108,11 @@ 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 import GHC.Types.Name.Reader ( RdrName ) import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Builtin.Names ( negateName ) import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type@@ -182,7 +189,7 @@ 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@@ -283,6 +290,8 @@ hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag hsTyVarBndrFlag (UserTyVar _ fl _)     = fl hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl+-- By specialising to (GhcPass p) we know that XXTyVarBndr is DataConCantHappen+-- so these two equations are exhaustive: extension construction can't happen  -- | Set the attached flag setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)@@ -290,6 +299,14 @@ setHsTyVarBndrFlag f (UserTyVar x _ l)     = UserTyVar x f l setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k +-- | Update the attached flag+updateHsTyVarBndrFlag+  :: (flag -> flag')+  -> HsTyVarBndr flag  (GhcPass pass)+  -> HsTyVarBndr flag' (GhcPass pass)+updateHsTyVarBndrFlag f (UserTyVar   x flag name)    = UserTyVar   x (f flag) name+updateHsTyVarBndrFlag f (KindedTyVar x flag name ki) = KindedTyVar x (f flag) name ki+ -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit@@ -312,7 +329,7 @@ type instance XStarTy          (GhcPass _) = NoExtField type instance XKindSig         (GhcPass _) = EpAnn [AddEpAnn] -type instance XAppKindTy       (GhcPass _) = SrcSpan -- Where the `@` lives+type instance XAppKindTy       (GhcPass _) = NoExtField  type instance XSpliceTy        GhcPs = NoExtField type instance XSpliceTy        GhcRn = HsUntypedSpliceResult (LHsType GhcRn)@@ -414,10 +431,20 @@   = 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 _ = []+ ---------------------+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> LIdP (GhcPass p)+hsTyVarLName (UserTyVar _ _ n)     = n+hsTyVarLName (KindedTyVar _ _ n _) = n+ hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)-hsTyVarName (UserTyVar _ _ (L _ n))     = n-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n+hsTyVarName = unLoc . hsTyVarLName  hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) hsLTyVarName = hsTyVarName . unLoc@@ -435,10 +462,12 @@                          , 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) -> LocatedN (IdP (GhcPass p))+hsLTyVarLocName (L _ a) = hsTyVarLName a -hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]+hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN+                 => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)  -- | Get the kind signature of a type, ignoring parentheses:@@ -489,10 +518,10 @@            -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy -mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p)               -> LHsType (GhcPass p)-mkHsAppKindTy ext ty k-  = addCLocAA ty k (HsAppKindTy ext ty k)+mkHsAppKindTy ty at k+  = addCLocAA ty k (HsAppKindTy noExtField ty at k)  {- ************************************************************************@@ -541,7 +570,7 @@   where     go (L _ (HsTyVar _ _ ln))          = Just ln     go (L _ (HsAppTy _ l _))           = go l-    go (L _ (HsAppKindTy _ t _))       = go t+    go (L _ (HsAppKindTy _ t _ _))     = go t     go (L _ (HsOpTy _ _ _ ln _))       = Just ln     go (L _ (HsParTy _ t))             = go t     go (L _ (HsKindSig _ t _))         = go t@@ -553,12 +582,12 @@ lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan lhsTypeArgSrcSpan arg = case arg of   HsValArg  tm    -> getLocA tm-  HsTypeArg at ty -> at `combineSrcSpans` getLocA ty+  HsTypeArg at ty -> getTokenSrcSpan (getLoc 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@@ -576,7 +605,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 p tm ty] -> SDoc pprHsArgsApp thing fixity (argl:argr:args)   | Infix <- fixity   = let pp_op_app = hsep [ ppr_single_hs_arg argl@@ -591,7 +620,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 p tm ty] -> SDoc ppr_hs_args_prefix_app acc []         = acc ppr_hs_args_prefix_app acc (arg:args) =   case arg of@@ -601,7 +630,7 @@  -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty)-                  => HsArg tm ty -> SDoc+                  => HsArg 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.@@ -611,9 +640,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+instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where   ppr (HsValArg tm)     = text "HsValArg"  <+> ppr tm-  ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty+  ppr (HsTypeArg at ty) = text "HsTypeArg" <+> ppr at <+> ppr ty   ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp  --------------------------------@@ -913,11 +942,11 @@ type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen  instance Outputable (AmbiguousFieldOcc (GhcPass p)) where-  ppr = ppr . rdrNameAmbiguousFieldOcc+  ppr = ppr . ambiguousFieldOccRdrName  instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where-  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc-  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc+  pprInfixOcc  = pprInfixOcc . ambiguousFieldOccRdrName+  pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName  instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where   pprInfixOcc  = pprInfixOcc . unLoc@@ -926,10 +955,13 @@ mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName-rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr-rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr+ambiguousFieldOccRdrName :: AmbiguousFieldOcc (GhcPass p) -> RdrName+ambiguousFieldOccRdrName = unLoc . ambiguousFieldOccLRdrName +ambiguousFieldOccLRdrName :: AmbiguousFieldOcc (GhcPass p) -> LocatedN RdrName+ambiguousFieldOccLRdrName (Unambiguous _ rdr) = rdr+ambiguousFieldOccLRdrName (Ambiguous   _ rdr) = rdr+ selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id selectorAmbiguousFieldOcc (Unambiguous sel _) = sel selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel@@ -944,6 +976,26 @@ {- ************************************************************************ *                                                                      *+                OpName+*                                                                      *+************************************************************************+-}++-- | Name of an operator in an operator application or section+data OpName = NormalOp Name             -- ^ A normal identifier+            | NegateOp                  -- ^ Prefix negation+            | UnboundOp RdrName         -- ^ An unbound identifier+            | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence++instance Outputable OpName where+  ppr (NormalOp n)   = ppr n+  ppr NegateOp       = ppr negateName+  ppr (UnboundOp uv) = ppr uv+  ppr (RecFldOp fld) = ppr fld++{-+************************************************************************+*                                                                      * \subsection{Pretty printing} *                                                                      * ************************************************************************@@ -962,6 +1014,15 @@     pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]     pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr n, dcolon, ppr k] +instance OutputableBndrFlag (HsBndrVis p') p where+    pprTyVarBndr (UserTyVar _ vis n) = pprHsBndrVis vis $ ppr n+    pprTyVarBndr (KindedTyVar _ vis n k) =+      pprHsBndrVis vis $ parens $ hsep [ppr n, dcolon, ppr k]++pprHsBndrVis :: HsBndrVis pass -> SDoc -> SDoc+pprHsBndrVis HsBndrRequired d = d+pprHsBndrVis (HsBndrInvisible _) d = char '@' <> d+ instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where     ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =       pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body@@ -1180,7 +1241,7 @@  ppr_mono_ty (HsAppTy _ fun_ty arg_ty)   = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]-ppr_mono_ty (HsAppKindTy _ ty k)+ppr_mono_ty (HsAppKindTy _ ty _ k)   = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)   = sep [ ppr_mono_lty ty1@@ -1295,7 +1356,7 @@     go (HsWildCardTy{})      = False     go (HsStarTy{})          = False     go (HsAppTy _ t _)       = goL t-    go (HsAppKindTy _ t _)   = goL t+    go (HsAppKindTy _ t _ _) = goL t     go (HsParTy{})           = False     go (HsDocTy _ t _)       = goL t     go (XHsType{})           = False
compiler/GHC/Hs/Utils.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections   #-}+ {-| Module      : GHC.Hs.Utils Description : Generic helpers for the HsSyn type.@@ -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@@ -86,7 +88,7 @@   mkLetStmt,    -- * Collecting binders-  isUnliftedHsBind, isBangedHsBind,+  isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind,    collectLocalBinders, collectHsValBinders, collectHsBindListBinders,   collectHsIdBinders,@@ -97,6 +99,7 @@   collectLStmtBinders, collectStmtBinders,   CollectPass(..), CollectFlag(..), +  TyDeclBinders(..), LConsWithFields(..),   hsLTyClDeclBinders, hsTyClForeignBinders,   hsPatSynSelectors, getPatSynBinds,   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,@@ -113,6 +116,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@@ -146,13 +150,18 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.Either+import Control.Arrow ( first )+import Data.Either ( partitionEithers ) import Data.Foldable ( toList )-import Data.Function-import Data.List ( partition, deleteBy )+import Data.List ( partition ) import Data.List.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+ {- ************************************************************************ *                                                                      *@@ -262,7 +271,7 @@         -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))   where-    matches = mkMatchGroup Generated+    matches = mkMatchGroup (Generated SkipPmc)                            (noLocA [mkSimpleMatch LambdaExpr pats' body])     pats' = map (parenthesizePat appPrec) pats @@ -590,7 +599,8 @@ nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs  -- AZ:Is this used?-nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))+nlHsLam match = noLocA $ HsLam noExtField+              $ mkMatchGroup (Generated SkipPmc) (noLocA [match]) nlHsPar e     = noLocA (gHsPar e)  -- nlHsIf should generate if-expressions which are NOT subject to@@ -599,7 +609,7 @@ 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 SkipPmc) (noLocA matches))) nlList exprs          = noLocA (ExplicitList noAnn exprs)  nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)@@ -628,13 +638,13 @@     mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn 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 (HsTypeArg at ki) = noLocA (HsAppKindTy noExtField fun at (parenthesizeHsType appPrec ki))     mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)  nlHsAppKindTy ::   LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k-  = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))+  = noLocA (HsAppKindTy noExtField f noHsTok (parenthesizeHsType appPrec k))  {- Tuples.  All these functions are *pre-typechecker* because they lack@@ -810,7 +820,7 @@ mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] 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 }@@ -856,9 +866,9 @@ -- | 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+                         -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr-  = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)+  = L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun)               [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr                        emptyLocalBinds] @@ -905,56 +915,107 @@ 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 = anyBag (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 }))@@ -1211,7 +1272,7 @@         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 +1366,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  --------------------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 +1401,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)@@ -1379,94 +1467,170 @@           , (unXRec @id -> (PatSynBind _ psb)) <- bagToList 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 [LConDeclField (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 (cd_fld_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 :: 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 = unLoc . foLabel . 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
compiler/GHC/HsToCore/Errors/Ppr.hs view
@@ -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@@ -299,11 +298,11 @@        2 (quotes (ppr elt_ty))  -- Print a single clause (for redundant/with-inaccessible-rhs)-pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc+pprEqn :: HsMatchContext GhcTc -> 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 -> HsMatchContext GhcTc -> 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
@@ -9,7 +9,8 @@ import GHC.Core (CoreRule, CoreExpr, RuleName) import GHC.Core.DataCon 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 +30,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage   -- | Simply wraps a generic 'Diagnostic' message.-  = DsUnknownMessage UnknownDiagnostic+  = DsUnknownMessage (UnknownDiagnostic (DiagnosticOpts DsMessage))      {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is         emitted if an enumeration is empty.@@ -84,18 +85,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 !(HsMatchContext GhcTc) !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 !(HsMatchContext GhcTc) !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc'-  | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc+  | DsInaccessibleRhs !(HsMatchContext GhcTc) !SDoc    | DsMaxPmCheckModelsReached !MaxPmCheckModels -  | DsNonExhaustivePatterns !(HsMatchContext GhcRn)+  | DsNonExhaustivePatterns !(HsMatchContext GhcTc)                             !ExhaustivityCheckType                             !MaxUncoveredPatterns                             [Id]@@ -154,7 +155,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)
+ compiler/GHC/Iface/Decl.hs view
@@ -0,0 +1,345 @@++{-# 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+   , toIfaceBooleanFormula+   )+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.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.Types.SrcLoc++import GHC.Utils.Panic.Plain+import GHC.Utils.Misc++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.BooleanFormula++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 "iface_incomps"+                        . 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  = 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 (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)+    ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data })+      = IfDataTyCon type_data (map ifaceConDecl cons)+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon False [ifaceConDecl con]+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon False (map ifaceConDecl cons)+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon+        -- The AbstractTyCon case happens when a TyCon has been trimmed+        -- during tidying.+        -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module+        -- for GHCi, when browsing a module, in which case the+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.+        -- (Tuple declarations are not serialised into interface files.)++    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 "ifaceConDecl" 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 -> InvisTVBinder -> InvisTVBinder+          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 $ fmap getOccFS (classMinimalDef clas)+            }++    (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 -> FastString+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)++toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula+toIfaceBooleanFormula = \case+    Var nm    -> IfVar    nm+    And bfs   -> IfAnd    (map (toIfaceBooleanFormula . unLoc) bfs)+    Or bfs    -> IfOr     (map (toIfaceBooleanFormula . unLoc) bfs)+    Parens bf -> IfParens (toIfaceBooleanFormula . unLoc $ bf)
+ compiler/GHC/Iface/Errors/Ppr.hs view
@@ -0,0 +1,383 @@+{-# 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.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 ( constructorCode )+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++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 (pkg, reason)+      = text "It is a member of the package"+      <+> quotes (ppr pkg)+      $$ 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 =+  -- ToDo: This will fail to have enough qualification when the package IDs+  -- are the same+  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+         , parens (text "if these names look the same, try again with -dppr-debug")+         ]++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, UnusableUnitReason, 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]+      [(Unit, UnusableUnitReason)] [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/Syntax.hs view
@@ -16,8 +16,9 @@         IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),         IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,+        IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..),         IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),-        IfaceClassBody(..),+        IfaceClassBody(..), IfaceBooleanFormula(..),         IfaceBang(..),         IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),         IfaceAxBranch(..),@@ -32,9 +33,12 @@         -- Misc         ifaceDeclImplicitBndrs, visibleIfConDecls,         ifaceDeclFingerprints,+        fromIfaceBooleanFormula,+        fromIfaceWarnings,          -- Free Names         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,+        freeNamesIfConDecls,          -- Pretty printing         pprIfaceExpr,@@ -44,6 +48,7 @@  import GHC.Prelude +import GHC.Data.FastString import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,                            constraintKindTyConKey ) import GHC.Types.Unique ( hasKey )@@ -63,13 +68,18 @@ import GHC.Types.Annotations( AnnPayload, AnnTarget ) import GHC.Types.Basic 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.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.InferTags.TagSig+import GHC.Parser.Annotation (noLocA)+import GHC.Hs.Extension ( GhcRn )+import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )  import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint@@ -80,8 +90,6 @@ import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,                        seqList, zipWithEqual ) -import Language.Haskell.Syntax.Basic (FieldLabelString(..))- import Control.Monad import System.IO.Unsafe import Control.DeepSeq@@ -191,9 +199,22 @@      ifClassCtxt :: IfaceContext,             -- Super classes      ifATs       :: [IfaceAT],                -- Associated type families      ifSigs      :: [IfaceClassOp],           -- Method signatures-     ifMinDef    :: BooleanFormula IfLclName  -- Minimal complete definition+     ifMinDef    :: IfaceBooleanFormula       -- Minimal complete definition     } +data IfaceBooleanFormula+  = IfVar IfLclName+  | IfAnd [IfaceBooleanFormula]+  | IfOr [IfaceBooleanFormula]+  | IfParens IfaceBooleanFormula++fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula IfLclName+fromIfaceBooleanFormula = \case+    IfVar nm     -> Var    nm+    IfAnd ibfs   -> And    (map (noLocA . fromIfaceBooleanFormula) ibfs)+    IfOr ibfs    -> Or     (map (noLocA . fromIfaceBooleanFormula) ibfs)+    IfParens ibf -> Parens (noLocA . fromIfaceBooleanFormula $ ibf)+ data IfaceTyConParent   = IfNoParent   | IfDataInstance@@ -323,6 +344,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,@@ -385,7 +418,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@@ -545,6 +582,24 @@        unsafeDupablePerformIO         . 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 (noLoc . fromWarningCategory <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)+    IfDeprecatedTxt src strs -> DeprecatedTxt (noLoc src) (noLoc <$> 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++ {- ************************************************************************ *                                                                      *@@ -574,7 +629,7 @@ data IfaceTickish   = IfaceHpcTick Module Int                -- from HpcTick x   | IfaceSCC     CostCentre Bool Bool      -- from ProfNote-  | IfaceSource  RealSrcSpan String        -- from SourceNote+  | IfaceSource  RealSrcSpan FastString        -- from SourceNote   -- no breakpoints: we never export these into interface files  data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr@@ -696,6 +751,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 +821,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,11 +834,6 @@ 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- showToHeader :: ShowSub showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing                        , ss_forall = ShowForAllWhen }@@ -952,7 +1002,7 @@          , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind)          , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> 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") @@ -1299,7 +1349,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]@@ -1504,10 +1554,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@@ -1623,9 +1673,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 +1711,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@@ -1860,7 +1914,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@@ -2056,6 +2110,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@@ -2254,6 +2322,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 +2353,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@@ -2659,8 +2757,15 @@ 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 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `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 @@ -2693,8 +2798,8 @@   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+    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@@ -2794,6 +2899,19 @@ instance NFData IfaceClsInst where   rnf (IfaceClsInst f1 f2 f3 f4 f5) =     f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()++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` ()
compiler/GHC/Iface/Type.hs view
@@ -29,6 +29,7 @@         IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,         IfaceForAllSpecBndr,         IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..),+        ShowSub(..), ShowHowMuch(..), AltPpr(..),         mkIfaceForAllTvBndr,         mkIfaceTyConKind,         ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr,@@ -206,7 +207,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]@@ -820,7 +821,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -880,7 +881,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 +894,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 +933,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@@ -991,7 +991,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 +1048,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 +1079,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 +1129,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      , Just substituted_ty <- check_substitution var_kind       = let subs' = extendFsEnv subs 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 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 +1171,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 +1269,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  -------------------@@ -1322,6 +1351,32 @@ -- 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 [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)++instance Outputable ShowHowMuch where+  ppr (ShowHeader _)    = text "ShowHeader"+  ppr ShowIface         = text "ShowIface"+  ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs+ pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty   = hideNonStandardTypes (ppr_sigma show_forall topPrec) ty@@ -1345,7 +1400,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
compiler/GHC/Iface/Type.hs-boot view
@@ -1,6 +1,7 @@ module GHC.Iface.Type    ( IfaceType, IfaceTyCon, IfaceBndr    , IfaceCoercion, IfaceTyLit, IfaceAppArgs+   , ShowSub    ) where @@ -15,3 +16,4 @@ data IfaceTyLit data IfaceCoercion data IfaceBndr+data ShowSub
+ compiler/GHC/JS/Make.hs view
@@ -0,0 +1,692 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr++-----------------------------------------------------------------------------+-- |+-- 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'. Notice+--           that the type of each of these functions have the domain @isSat a+--           => a -> ...@; indicating that they each take something that /can/+--           be injected into the EDSL domain, and the range 'JExpr' or 'JStat';+--           indicating the corresponding value in the EDSL domain. Similarly+--           this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr'+--           injects values as a JS expression into the EDSL. 'ToSat' ensures+--           that terms introduced into the EDSL carry identifier information so+--           terms in the EDSL must have meaning.+--+--      * /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.+-----------------------------------------------------------------------------+module GHC.JS.Make+  ( -- * Injection Type classes+    -- $classes+    ToJExpr(..)+  , ToStat(..)+  -- * Introduction functions+  -- $intro_funcs+  , var+  , jString+  , jLam, jFun, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally+  -- * Combinators+  -- $combinators+  , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)+  , (.>.), (.>=.), (.<.), (.<=.)+  , (.<<.), (.>>.), (.>>>.)+  , (.|.), (.||.), (.&&.)+  , if_, if10, if01, ifS, ifBlockS+  , 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, (.^)+  , trace+  -- ** 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+  -- * Statement helpers+  , decl+  )+where++import GHC.Prelude hiding ((.|.))++import GHC.JS.Unsat.Syntax++import Control.Arrow ((***))++import qualified Data.Map as M++import GHC.Data.FastString+import GHC.Utils.Monad.State.Strict+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   -> JExpr+    toJExprFromList :: [a] -> JExpr+    toJExprFromList = ValExpr . JList . map toJExpr++instance ToJExpr a => ToJExpr [a] where+    toJExpr = toJExprFromList++instance ToJExpr JExpr where+    toJExpr = id++instance ToJExpr () where+    toJExpr _ = ValExpr $ JList []++instance ToJExpr Bool where+    toJExpr True  = var "true"+    toJExpr False = var "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 -> JStat++instance ToStat JStat where+    toStat = id++instance ToStat [JStat] where+    toStat = BlockStat++instance ToStat JExpr where+    toStat = expr2stat++instance ToStat [JExpr] where+    toStat = BlockStat . map expr2stat++--------------------------------------------------------------------------------+--                        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 :: ToSat a => a -> JExpr+jLam f = ValExpr . UnsatVal . IS $ do+           (block,is) <- runIdentSupply $ toSat_ f []+           return $ JFunc is block++-- | Create a new function. The result is a 'GHC.JS.Syntax.JStat'.+-- Usage:+--+-- > jFun fun_name $ \x -> ...+jFun :: ToSat a => Ident -> a -> JStat+jFun n f = UnsatBlock . IS $ do+           (block,is) <- runIdentSupply $ toSat_ f []+           return $ FuncStat n is block++-- | Introduce a new variable into scope for the duration+-- of the enclosed expression. The result is a block statement.+-- Usage:+--+-- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@+jVar :: ToSat a => a -> JStat+jVar f = UnsatBlock . IS $ do+           (block, is) <- runIdentSupply $ toSat_ f []+           let addDecls (BlockStat ss) =+                  BlockStat $ map decl is ++ ss+               addDecls x = x+           return $ addDecls block++jFunction :: Ident -> [Ident] -> JStat -> JStat+jFunction name args body = FuncStat name args body++-- | Create a 'for in' statement.+-- Usage:+--+-- @jForIn {expression} $ \x -> {block involving x}@+jForIn :: ToSat a => JExpr -> (JExpr -> a)  -> JStat+jForIn e f = UnsatBlock . IS $ do+               (block, is) <- runIdentSupply $ toSat_ f []+               let i = head is+               return $ decl i `mappend` ForInStat False i e block++-- | As with "jForIn" but creating a \"for each in\" statement.+jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat+jForEachIn e f = UnsatBlock . IS $ do+               (block, is) <- runIdentSupply $ toSat_ f []+               let i = head is+               return $ decl i `mappend` ForInStat True i e block++-- | 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 :: (JExpr -> JStat)+     -> (JExpr -> JExpr)+     -> (JExpr -> JStat)+     -> (JExpr -> JStat)+     -> JStat+jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i)++jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat+jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body++-- | As with "jForIn" but creating a \"for each in\" statement.+jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat+jTryCatchFinally s f s2 = UnsatBlock . IS $ do+                     (block, is) <- runIdentSupply $ toSat_ f []+                     let i = head is+                     return $ TryStat s i block s2++-- | construct a JS variable reference+var :: FastString -> JExpr+var = ValExpr . JVar . TxtI++-- | Convert a ShortText to a Javascript String+jString :: FastString -> JExpr+jString = toJExpr++-- | construct a js declaration with the given identifier+decl :: Ident -> JStat+decl i = DeclStat i Nothing++-- | The empty JS HashMap+jhEmpty :: M.Map k JExpr+jhEmpty = M.empty++-- | A singleton JS HashMap+jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr+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 JExpr -> M.Map k JExpr+jhAdd  k v m = M.insert k (toJExpr v) m++-- | Construct a JS HashMap from a list of key-value pairs+jhFromList :: [(FastString, JExpr)] -> JVal+jhFromList = JHash . listToUniqMap++-- | The empty JS statement+nullStat :: JStat+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+(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr+(.==.)  = InfixExpr EqOp+(.===.) = InfixExpr StrictEqOp+(.!=.)  = InfixExpr NeqOp+(.!==.) = InfixExpr StrictNeqOp++infixl 6 .==., .===., .!=., .!==.++-- | JS infix Ord operators+(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr+(.>.)  = InfixExpr GtOp+(.>=.) = InfixExpr GeOp+(.<.)  = InfixExpr LtOp+(.<=.) = InfixExpr LeOp++infixl 7 .>., .>=., .<., .<=.++-- | JS infix bit operators+(.|.), (.||.), (.&&.)  :: JExpr -> JExpr -> JExpr+(.|.)   = InfixExpr BOrOp+(.||.)  = InfixExpr LOrOp+(.&&.)  = InfixExpr LAndOp++infixl 8 .||., .&&.++-- | JS infix bit shift operators+(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr+(.<<.)  = InfixExpr LeftShiftOp+(.>>.)  = InfixExpr RightShiftOp+(.>>>.) = InfixExpr ZRightShiftOp++infixl 9 .<<., .>>., .>>>.++-- | Given a 'JExpr', return the its type.+typeof :: JExpr -> JExpr+typeof = UOpExpr TypeofOp++-- | JS if-expression+--+-- > if_ e1 e2 e3 ==> e1 ? e2 : e3+if_ :: JExpr -> JExpr -> JExpr -> JExpr+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 :: JExpr -> JStat -> JStat -> JStat+ifS e s1 s2 = IfStat e s1 s2++-- | A when-statement as syntactic sugar via `ifS`+--+-- > jwhenS cond block ==> if(cond) { block } else {  }+jwhenS :: JExpr -> JStat -> JStat+jwhenS cond block = ifS cond block mempty++-- | If-expression which returns blocks+--+-- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 }+ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat+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 :: JExpr -> JExpr+if10 e = IfExpr e one_ zero_++-- | if-expression that returns 0 if condition <=> true, 1 otherwise+--+-- > if01 e ==> e ? 0 : 1+if01 :: JExpr -> JExpr+if01 e = IfExpr e zero_ one_++-- | an expression application, see related 'appS'+--+-- > app f xs ==> f(xs)+app :: FastString -> [JExpr] -> JExpr+app f xs = ApplExpr (var f) xs++-- | A statement application, see the expression form 'app'+appS :: FastString -> [JExpr] -> JStat+appS f xs = ApplStat (var f) xs++-- | Return a 'JExpr'+returnS :: JExpr -> JStat+returnS e = ReturnStat e++-- | "for" loop with increment at end of body+loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat+loop initial test body = jVar $ \i ->+  mconcat [ i |= initial+          , WhileStat False (test i) (body i)+          ]++-- | "for" loop with increment at end of body+loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat+loopBlockS initial test body = jVar $ \i ->+  mconcat [ i |= initial+          , WhileStat False (test i) (mconcat (body i))+          ]++-- | Prefix-increment a 'JExpr'+preIncrS :: JExpr -> JStat+preIncrS x = UOpStat PreIncOp x++-- | Postfix-increment a 'JExpr'+postIncrS :: JExpr -> JStat+postIncrS x = UOpStat PostIncOp x++-- | Prefix-decrement a 'JExpr'+preDecrS :: JExpr -> JStat+preDecrS x = UOpStat PreDecOp x++-- | Postfix-decrement a 'JExpr'+postDecrS :: JExpr -> JStat+postDecrS x = UOpStat PostDecOp x++-- | Byte indexing of o with a 64-bit offset+off64 :: JExpr -> JExpr -> JExpr+off64 o i = Add o (i .<<. three_)++-- | Byte indexing of o with a 32-bit offset+off32 :: JExpr -> JExpr -> JExpr+off32 o i = Add o (i .<<. two_)++-- | Byte indexing of o with a 16-bit offset+off16 :: JExpr -> JExpr -> JExpr+off16 o i = Add o (i .<<. one_)++-- | Byte indexing of o with a 8-bit offset+off8 :: JExpr -> JExpr -> JExpr+off8 o i = Add o i++-- | a bit mask to retrieve the lower 8-bits+mask8 :: JExpr -> JExpr+mask8 x = BAnd x (Int 0xFF)++-- | a bit mask to retrieve the lower 16-bits+mask16 :: JExpr -> JExpr+mask16 x = BAnd x (Int 0xFFFF)++-- | Sign-extend/narrow a 8-bit value+signExtend8 :: JExpr -> JExpr+signExtend8 x = (BAnd x (Int 0x7F  )) `Sub` (BAnd x (Int 0x80))++-- | Sign-extend/narrow a 16-bit value+signExtend16 :: JExpr -> JExpr+signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000))++-- | Select a property 'prop', from and object 'obj'+--+-- > obj .^ prop ==> obj.prop+(.^) :: JExpr -> FastString -> JExpr+obj .^ prop = SelExpr obj (TxtI prop)+infixl 8 .^++-- | Assign a variable to an expression+--+-- > foo |= expr ==> var foo = expr;+(|=) :: JExpr -> JExpr -> JStat+(|=) = AssignStat++-- | Declare a variable and then Assign the variable to an expression+--+-- > foo |= expr ==> var foo; foo = expr;+(||=) :: Ident -> JExpr -> JStat+i ||= ex = DeclStat i (Just ex)++infixl 2 ||=, |=++-- | return the expression at idx of obj+--+-- > obj .! idx ==> obj[idx]+(.!) :: JExpr -> JExpr -> JExpr+(.!) = IdxExpr++infixl 8 .!++assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat+assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys)++assignAll :: [JExpr] -> [JExpr] -> JStat+assignAll xs ys = mconcat (zipWith (|=) xs ys)++assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat+assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys))++declAssignAll :: [Ident] -> [JExpr] -> JStat+declAssignAll xs ys = mconcat (zipWith (||=) xs ys)++trace :: ToJExpr a => a -> JStat+trace ex = appS "h$log" [toJExpr ex]+++--------------------------------------------------------------------------------+--                             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_ :: JExpr+null_ = var "null"++-- | The JS literal 0+zero_ :: JExpr+zero_ = Int 0++-- | The JS literal 1+one_ :: JExpr+one_ = Int 1++-- | The JS literal 2+two_ :: JExpr+two_ = Int 2++-- | The JS literal 3+three_ :: JExpr+three_ = Int 3++-- | The JS literal 'undefined'+undefined_ :: JExpr+undefined_ = var "undefined"++-- | The JS literal 'true'+true_ :: JExpr+true_ = var "true"++-- | The JS literal 'false'+false_ :: JExpr+false_ = var "false"++returnStack :: JStat+returnStack = ReturnStat (ApplExpr (var "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 :: JExpr+math = var "Math"++math_ :: FastString -> [JExpr] -> JExpr+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+  :: [JExpr] -> JExpr+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"++instance Num JExpr 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 JExpr where+    x / y = InfixExpr DivOp x y+    fromRational x = ValExpr (JDouble (realToFrac x))+++--------------------------------------------------------------------------------+-- New Identifiers+--------------------------------------------------------------------------------++-- | The 'ToSat' class is heavily used in the Introduction function. It ensures+-- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'.+class ToSat a where+    toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident])++instance ToSat [JStat] where+    toSat_ f vs = IS $ return $ (BlockStat f, reverse vs)++instance ToSat JStat where+    toSat_ f vs = IS $ return $ (f, reverse vs)++instance ToSat JExpr where+    toSat_ f vs = IS $ return $ (toStat f, reverse vs)++instance ToSat [JExpr] where+    toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs)++instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where+    toSat_ f vs = IS $ do+      x <- takeOneIdent+      runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs)++-- | Convert A JS expression to a JS statement where applicable. This only+-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary+-- expression; 'UOpExpr'.+expr2stat :: JExpr -> JStat+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++takeOneIdent :: State [Ident] Ident+takeOneIdent = do+  xxs <- get+  case xxs of+    (x:xs) -> do+      put xs+      return x+    _ -> error "takeOneIdent: empty list"+
+ 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 #-}+{-# LANGUAGE TypeApplications #-}++-- 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 intances 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.Syntax+import GHC.JS.Transform+++import Data.Char (isControl, ord)+import Data.List (sortOn)++import Numeric(showHex)++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, JMacro a) => a -> SDoc+renderPrefixJs = renderPrefixJs' defaultRenderJs++renderPrefixJs' :: (JsToDoc a, JMacro 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 ($$$) 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 '/'+  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 _ (TxtI t) = ftext 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,351 @@+{-# 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 embeded 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 JNew+  , pattern JNot+  , pattern JNegate+  , pattern JAdd+  , pattern JSub+  , pattern JMul+  , pattern JDiv+  , pattern JMod+  , pattern JBOr+  , pattern JBAnd+  , pattern JBXor+  , pattern JBNot+  , pattern JLOr+  , pattern JLAnd+  , pattern SatInt+  , pattern JString+  , pattern JPreInc+  , pattern JPostInc+  , pattern JPreDec+  , pattern JPostDec+  -- * Utility+  , SaneDouble(..)+  , jassignAll+  , jassignAllEqual+  , jvar+  ) where++import GHC.Prelude++import GHC.JS.Unsat.Syntax (Ident(..))+import GHC.Data.FastString+import GHC.Types.Unique.Map+import GHC.Types.SaneDouble+import GHC.Utils.Misc++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, Typeable, 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, Typeable, Generic)++-- * Useful pattern synonyms to ease programming with the deeply embedded JS+--   AST. Each pattern wraps @JUOp@ and @JOp@ 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 JNew :: JExpr -> JExpr+pattern JNew x = UOpExpr NewOp x++-- | pattern synonym for prefix increment @++x@+pattern JPreInc :: JExpr -> JExpr+pattern JPreInc x = UOpExpr PreIncOp x++-- | pattern synonym for postfix increment @x++@+pattern JPostInc :: JExpr -> JExpr+pattern JPostInc x = UOpExpr PostIncOp x++-- | pattern synonym for prefix decrement @--x@+pattern JPreDec :: JExpr -> JExpr+pattern JPreDec x = UOpExpr PreDecOp x++-- | pattern synonym for postfix decrement @--x@+pattern JPostDec :: JExpr -> JExpr+pattern JPostDec x = UOpExpr PostDecOp x++-- | pattern synonym for logical not @!@+pattern JNot :: JExpr -> JExpr+pattern JNot x = UOpExpr NotOp x++-- | pattern synonym for unary negation @-@+pattern JNegate :: JExpr -> JExpr+pattern JNegate x = UOpExpr NegOp x++-- | pattern synonym for addition @+@+pattern JAdd :: JExpr -> JExpr -> JExpr+pattern JAdd x y = InfixExpr AddOp x y++-- | pattern synonym for subtraction @-@+pattern JSub :: JExpr -> JExpr -> JExpr+pattern JSub x y = InfixExpr SubOp x y++-- | pattern synonym for multiplication @*@+pattern JMul :: JExpr -> JExpr -> JExpr+pattern JMul x y = InfixExpr MulOp x y++-- | pattern synonym for division @*@+pattern JDiv :: JExpr -> JExpr -> JExpr+pattern JDiv x y = InfixExpr DivOp x y++-- | pattern synonym for remainder @%@+pattern JMod :: JExpr -> JExpr -> JExpr+pattern JMod x y = InfixExpr ModOp x y++-- | pattern synonym for Bitwise Or @|@+pattern JBOr :: JExpr -> JExpr -> JExpr+pattern JBOr x y = InfixExpr BOrOp x y++-- | pattern synonym for Bitwise And @&@+pattern JBAnd :: JExpr -> JExpr -> JExpr+pattern JBAnd x y = InfixExpr BAndOp x y++-- | pattern synonym for Bitwise XOr @^@+pattern JBXor :: JExpr -> JExpr -> JExpr+pattern JBXor x y = InfixExpr BXorOp x y++-- | pattern synonym for Bitwise Not @~@+pattern JBNot :: JExpr -> JExpr+pattern JBNot x = UOpExpr BNotOp x++-- | pattern synonym for logical Or @||@+pattern JLOr :: JExpr -> JExpr -> JExpr+pattern JLOr x y = InfixExpr LOrOp x y++-- | pattern synonym for logical And @&&@+pattern JLAnd :: JExpr -> JExpr -> JExpr+pattern JLAnd x y = InfixExpr LAndOp x y++-- | pattern synonym to create integer values+pattern SatInt :: Integer -> JExpr+pattern SatInt x = ValExpr (JInt x)++-- | pattern synonym to create string values+pattern JString :: FastString -> JExpr+pattern JString x = ValExpr (JStr 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+  | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@+  | JFunc    [Ident] JStat             -- ^ A function+  deriving (Eq, Typeable, 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, Typeable, 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, Typeable, Generic)++instance NFData UOp++-- | JS Unary Operators+data AOp+  = AssignOp    -- ^ Vanilla  Assignment: =+  | AddAssignOp -- ^ Addition Assignment: +=+  | SubAssignOp -- ^ Subtraction Assignment: -=+  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)++instance NFData AOp++--------------------------------------------------------------------------------+--                            Helper Functions+--------------------------------------------------------------------------------++jassignAllEqual :: [JExpr] -> [JExpr] -> JStat+jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys)+  where go l r = AssignStat l AssignOp r++jassignAll :: [JExpr] -> [JExpr] -> JStat+jassignAll xs ys = mconcat $ zipWith go xs ys+  where go l r = AssignStat l AssignOp r++jvar :: FastString -> JExpr+jvar = ValExpr . JVar . TxtI+
+ compiler/GHC/JS/Transform.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TupleSections #-}++module GHC.JS.Transform+  ( identsS+  , identsV+  , identsE+  -- * Saturation+  , satJStat+  , satJExpr+  -- * Generic traversal (via compos)+  , JMacro(..)+  , JMGadt(..)+  , Compos(..)+  , composOp+  , composOpM+  , composOpM_+  , composOpFold+  )+where++import GHC.Prelude++import qualified GHC.JS.Syntax as Sat+import GHC.JS.Unsat.Syntax++import Data.Functor.Identity+import Control.Monad+import Data.List (sortBy)++import GHC.Data.FastString+import GHC.Utils.Monad.State.Strict+import GHC.Types.Unique.Map+import GHC.Types.Unique.FM+++{-# INLINE identsS #-}+identsS :: Sat.JStat -> [Ident]+identsS = \case+  Sat.DeclStat i e       -> [i] ++ maybe [] identsE e+  Sat.ReturnStat e       -> identsE e+  Sat.IfStat e s1 s2     -> identsE e ++ identsS s1 ++ identsS s2+  Sat.WhileStat _ e s    -> identsE e ++ identsS s+  Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body+  Sat.ForInStat _ i e s  -> [i] ++ identsE e ++ identsS s+  Sat.SwitchStat e xs s  -> identsE e ++ concatMap traverseCase xs ++ identsS s+                               where traverseCase (e,s) = identsE e ++ identsS s+  Sat.TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3+  Sat.BlockStat xs       -> concatMap identsS xs+  Sat.ApplStat e es      -> identsE e ++ concatMap identsE es+  Sat.UOpStat _op e      -> identsE e+  Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2+  Sat.LabelStat _l s     -> identsS s+  Sat.BreakStat{}        -> []+  Sat.ContinueStat{}     -> []+  Sat.FuncStat i args body -> [i] ++ args ++ identsS body++{-# INLINE identsE #-}+identsE :: Sat.JExpr -> [Ident]+identsE = \case+  Sat.ValExpr v         -> identsV v+  Sat.SelExpr e _i      -> identsE e -- do not rename properties+  Sat.IdxExpr e1 e2     -> identsE e1 ++ identsE e2+  Sat.InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2+  Sat.UOpExpr _ e       -> identsE e+  Sat.IfExpr e1 e2 e3   -> identsE e1 ++ identsE e2 ++ identsE e3+  Sat.ApplExpr e es     -> identsE e  ++ concatMap identsE es++{-# INLINE identsV #-}+identsV :: Sat.JVal -> [Ident]+identsV = \case+  Sat.JVar i       -> [i]+  Sat.JList xs     -> concatMap identsE xs+  Sat.JDouble{}    -> []+  Sat.JInt{}       -> []+  Sat.JStr{}       -> []+  Sat.JRegEx{}     -> []+  Sat.JHash m      -> concatMap identsE (nonDetEltsUniqMap m)+  Sat.JFunc args s -> args ++ identsS s+++{--------------------------------------------------------------------+  Compos+--------------------------------------------------------------------}+-- | Compos and ops for generic traversal as defined over+-- the JMacro ADT.++-- | Utility class to coerce the ADT into a regular structure.++class JMacro a where+    jtoGADT :: a -> JMGadt a+    jfromGADT :: JMGadt a -> a++instance JMacro Ident where+    jtoGADT = JMGId+    jfromGADT (JMGId x) = x++instance JMacro JStat where+    jtoGADT = JMGStat+    jfromGADT (JMGStat x) = x++instance JMacro JExpr where+    jtoGADT = JMGExpr+    jfromGADT (JMGExpr x) = x++instance JMacro JVal where+    jtoGADT = JMGVal+    jfromGADT (JMGVal x) = x++-- | Union type to allow regular traversal by compos.+data JMGadt a where+    JMGId   :: Ident -> JMGadt Ident+    JMGStat :: JStat -> JMGadt JStat+    JMGExpr :: JExpr -> JMGadt JExpr+    JMGVal  :: JVal  -> JMGadt JVal++composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b+composOp f = runIdentity . composOpM (Identity . f)++composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b)+composOpM = compos return ap++composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m ()+composOpM_ = composOpFold (return ()) (>>)++composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b+composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)++newtype C b a = C { unC :: b }++class Compos t where+    compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)+           -> (forall a. t a -> m (t a)) -> t c -> m (t c)++instance Compos JMGadt where+    compos = jmcompos++jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c)+jmcompos ret app f' v =+    case v of+     JMGId _ -> ret v+     JMGStat v' -> ret JMGStat `app` case v' of+           DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e+           ReturnStat i -> ret ReturnStat `app` f i+           IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'+           WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s+           ForStat init p step body -> ret ForStat  `app` f init `app` f p+                                           `app` f step `app` f body+           ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s+           SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d+               where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l+           BlockStat xs -> ret BlockStat `app` mapM' f xs+           ApplStat  e xs -> ret ApplStat `app` f e `app` mapM' f xs+           TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2+           UOpStat o e -> ret (UOpStat o) `app` f e+           AssignStat e e' -> ret AssignStat `app` f e `app` f e'+           UnsatBlock _ -> ret v'+           ContinueStat l -> ret (ContinueStat l)+           FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body+           BreakStat l -> ret (BreakStat l)+           LabelStat l s -> ret (LabelStat l) `app` f s+     JMGExpr v' -> ret JMGExpr `app` case v' of+           ValExpr e -> ret ValExpr `app` f e+           SelExpr e e' -> ret SelExpr `app` f e `app` f e'+           IdxExpr e e' -> ret IdxExpr `app` f e `app` f e'+           InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e'+           UOpExpr o e -> ret (UOpExpr o) `app` f e+           IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e''+           ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs+           UnsatExpr _ -> ret v'+     JMGVal v' -> ret JMGVal `app` case v' of+           JVar i -> ret JVar `app` f i+           JList xs -> ret JList `app` mapM' f xs+           JDouble _ -> ret v'+           JInt    _ -> ret v'+           JStr    _ -> ret v'+           JRegEx  _ -> ret v'+           JHash   m -> ret JHash `app` m'+               -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the+               -- elements are treated independently before being re-added to a UniqMap+               where (ls, vs) = unzip (nonDetUniqMapToList m)+                     m' = ret (listToUniqMap . zip ls) `app` mapM' f vs+           JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s+           UnsatVal _ -> ret v'++  where+    mapM' :: forall a. (a -> m a) -> [a] -> m [a]+    mapM' g = foldr (app . app (ret (:)) . g) (ret [])+    mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a)+    mapMaybeM' g = \case+      Nothing -> ret Nothing+      Just a  -> app (ret Just) (g a)+    f :: forall b. JMacro b => b -> m b+    f x = ret jfromGADT `app` f' (jtoGADT x)++{--------------------------------------------------------------------+  Saturation+--------------------------------------------------------------------}++-- | Given an optional prefix, fills in all free variable names with a supply+-- of names generated by the prefix.+satJStat :: Maybe FastString -> JStat -> Sat.JStat+satJStat str x = evalState (jsSaturateS x) (newIdentSupply str)++satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr+satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str)++jsSaturateS :: JStat -> State [Ident] Sat.JStat+jsSaturateS  = \case+  DeclStat i rhs        -> Sat.DeclStat i <$> mapM jsSaturateE rhs+  ReturnStat e          -> Sat.ReturnStat <$> jsSaturateE e+  IfStat c t e          -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e+  WhileStat is_do c e   -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e+  ForStat init p step body -> Sat.ForStat <$> jsSaturateS init <*> jsSaturateE p+                                          <*> jsSaturateS step <*> jsSaturateS body+  ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body+  SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct+                                             <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps+                                             <*> jsSaturateS def+  TryStat t i c f       -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f+  BlockStat bs          -> fmap Sat.BlockStat $! mapM jsSaturateS bs+  ApplStat rator rand   -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand+  UOpStat  rator rand   -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand+  AssignStat lhs rhs    -> Sat.AssignStat <$> jsSaturateE lhs <*> pure Sat.AssignOp <*> jsSaturateE rhs+  LabelStat lbl stmt    -> Sat.LabelStat lbl <$> jsSaturateS stmt+  BreakStat m_l         -> return $ Sat.BreakStat $! m_l+  ContinueStat m_l      -> return $ Sat.ContinueStat $! m_l+  FuncStat i args body  -> Sat.FuncStat i args <$> jsSaturateS body+  UnsatBlock us         -> jsSaturateS =<< runIdentSupply us++jsSaturateE :: JExpr -> State [Ident] Sat.JExpr+jsSaturateE = \case+  ValExpr v            -> Sat.ValExpr <$> jsSaturateV v+  SelExpr obj i        -> Sat.SelExpr <$> jsSaturateE obj <*> pure i+  IdxExpr o i          -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i+  InfixExpr op l r     -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r+  UOpExpr op r         -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r+  IfExpr c t e         -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e+  ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands+  UnsatExpr us         -> jsSaturateE =<< runIdentSupply us++jsSaturateV :: JVal -> State [Ident] Sat.JVal+jsSaturateV = \case+  JVar i   -> return $ Sat.JVar i+  JList xs -> Sat.JList <$> mapM jsSaturateE xs+  JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d))+  JInt i    -> return $ Sat.JInt   i+  JStr s    -> return $ Sat.JStr   s+  JRegEx f  -> return $ Sat.JRegEx f+  JHash m   -> Sat.JHash <$> mapUniqMapM satHash m+    where+      satHash (i, x) = (i,) . (i,) <$> jsSaturateE 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 <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m)+  JFunc args body   -> Sat.JFunc args <$> jsSaturateS body+  UnsatVal us       -> jsSaturateV =<< runIdentSupply us++satJOp :: JOp -> Sat.Op+satJOp = go+  where+    go EqOp         = Sat.EqOp+    go StrictEqOp   = Sat.StrictEqOp+    go NeqOp        = Sat.NeqOp+    go StrictNeqOp  = Sat.StrictNeqOp+    go GtOp         = Sat.GtOp+    go GeOp         = Sat.GeOp+    go LtOp         = Sat.LtOp+    go LeOp         = Sat.LeOp+    go AddOp        = Sat.AddOp+    go SubOp        = Sat.SubOp+    go MulOp        = Sat.MulOp+    go DivOp        = Sat.DivOp+    go ModOp        = Sat.ModOp+    go LeftShiftOp  = Sat.LeftShiftOp+    go RightShiftOp = Sat.RightShiftOp+    go ZRightShiftOp = Sat.ZRightShiftOp+    go BAndOp       = Sat.BAndOp+    go BOrOp        = Sat.BOrOp+    go BXorOp       = Sat.BXorOp+    go LAndOp       = Sat.LAndOp+    go LOrOp        = Sat.LOrOp+    go InstanceofOp = Sat.InstanceofOp+    go InOp         = Sat.InOp++satJUOp :: JUOp -> Sat.UOp+satJUOp = go+  where+    go NotOp     = Sat.NotOp+    go BNotOp    = Sat.BNotOp+    go NegOp     = Sat.NegOp+    go PlusOp    = Sat.PlusOp+    go NewOp     = Sat.NewOp+    go TypeofOp  = Sat.TypeofOp+    go DeleteOp  = Sat.DeleteOp+    go YieldOp   = Sat.YieldOp+    go VoidOp    = Sat.VoidOp+    go PreIncOp  = Sat.PreIncOp+    go PostIncOp = Sat.PostIncOp+    go PreDecOp  = Sat.PreDecOp+    go PostDecOp = Sat.PostDecOp+
+ compiler/GHC/JS/Unsat/Syntax.hs view
@@ -0,0 +1,375 @@+{-# 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.Unsat.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.Unsat.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 embeded 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.Unsat.Syntax+  ( -- * Deeply embedded JS datatypes+    JStat(..)+  , JExpr(..)+  , JVal(..)+  , JOp(..)+  , JUOp(..)+  , Ident(..)+  , identFS+  , 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 PreInc+  , pattern PostInc+  , pattern PreDec+  , pattern PostDec+  -- * Ident supply+  , IdentSupply(..)+  , newIdentSupply+  , pseudoSaturate+  -- * Utility+  , SaneDouble(..)+  ) where++import GHC.Prelude++import Control.DeepSeq++import Data.Function+import Data.Data+import Data.Word+import qualified Data.Semigroup as Semigroup++import GHC.Generics++import GHC.Data.FastString+import GHC.Utils.Monad.State.Strict+import GHC.Types.Unique+import GHC.Types.Unique.Map+import GHC.Types.SaneDouble++-- | A supply of identifiers, possibly empty+newtype IdentSupply a+  = IS {runIdentSupply :: State [Ident] a}+  deriving Typeable++instance NFData (IdentSupply a) where rnf IS{} = ()++inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b+inIdentSupply f x = IS $ f (runIdentSupply x)++instance Functor IdentSupply where+    fmap f x = inIdentSupply (fmap f) x++newIdentSupply :: Maybe FastString -> [Ident]+newIdentSupply Nothing    = newIdentSupply (Just "jmId")+newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)])+                            | x <- [(0::Word64)..]+                            ]++-- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers.+pseudoSaturate :: IdentSupply a -> a+pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>")++instance Eq a => Eq (IdentSupply a) where+    (==) = (==) `on` pseudoSaturate+instance Ord a => Ord (IdentSupply a) where+    compare = compare `on` pseudoSaturate+instance Show a => Show (IdentSupply a) where+    show x = "(" ++ show (pseudoSaturate x) ++ ")"+++--------------------------------------------------------------------------------+--                            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 JUOp JExpr                       -- ^ Unary operators+  | AssignStat JExpr JExpr                   -- ^ Binding form: @foo = bar@+  | UnsatBlock (IdentSupply JStat)           -- ^ /Unsaturated/ blocks see 'pseudoSaturate'+  | LabelStat JsLabel JStat                  -- ^ Statement Labels, makes me nostalgic for qbasic+  | BreakStat (Maybe JsLabel)                -- ^ Break+  | ContinueStat (Maybe JsLabel)             -- ^ Continue+  | FuncStat   !Ident [Ident] JStat          -- ^ an explicit function definition+  deriving (Eq, Typeable, Generic)++-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of+-- course 'LabelStat'+type JsLabel = 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  JOp JExpr JExpr      -- ^ Infix Expressions, see 'JExpr'+                                    --   pattern synonyms+  | UOpExpr    JUOp JExpr           -- ^ Unary Expressions+  | IfExpr     JExpr JExpr JExpr    -- ^ If-expression+  | ApplExpr   JExpr [JExpr]        -- ^ Application+  | UnsatExpr  (IdentSupply JExpr)  -- ^ An /Saturated/ expression.+                                    --   See 'pseudoSaturate'+  deriving (Eq, Typeable, Generic)++-- * Useful pattern synonyms to ease programming with the deeply embedded JS+--   AST. Each pattern wraps @JUOp@ and @JOp@ 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)+++--------------------------------------------------------------------------------+--                            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+  | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@+  | JFunc    [Ident] JStat              -- ^ A function+  | UnsatVal (IdentSupply JVal)         -- ^ An /Saturated/ value, see 'pseudoSaturate'+  deriving (Eq, Typeable, Generic)++--------------------------------------------------------------------------------+--                            Operators+--------------------------------------------------------------------------------+-- | JS Binary Operators. We do not deeply embed the comma operator and the+-- assignment operators+data JOp+  = 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, Typeable, Generic)++instance NFData JOp++-- | JS Unary Operators+data JUOp+  = 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, Typeable, Generic)++instance NFData JUOp++--------------------------------------------------------------------------------+--                            Identifiers+--------------------------------------------------------------------------------+-- We use FastString for identifiers in JS backend++-- | A newtype wrapper around 'FastString' for JS identifiers.+newtype Ident = TxtI { itxt :: FastString }+ deriving stock   (Show, Eq)+ deriving newtype (Uniquable)++identFS :: Ident -> FastString+identFS = \case+  TxtI fs -> fs
compiler/GHC/Linker/Types.hs view
@@ -108,7 +108,7 @@     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
compiler/GHC/Parser.y view
@@ -540,8 +540,9 @@ 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.+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:@@ -717,6 +718,14 @@  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 _) } @@ -764,9 +773,9 @@         | qvarop                        { $1 }         | qconop                        { $1 }     | '(' '->' ')'      {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+                                 (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }     | '->'              {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnnRArrow (glAA $1) []) }+                                 (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }  ----------------------------------------------------------------------------- -- Backpack stuff@@ -886,7 +895,7 @@        : '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)+                                               (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs)                                                (thdOf3 $6) $3 Nothing)                                             (Just $2) $4 (fst $ sndOf3 $6)                                             (snd $ sndOf3 $6)))@@ -895,16 +904,16 @@ 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)+                acsFinal (\cs eof -> (L loc (HsModule (XModulePs+                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6) eof) 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)+                   acsFinal (\cs eof -> (L loc (HsModule (XModulePs+                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1) eof) cs)                                                         (thdOf3 $1) Nothing Nothing)                                                      Nothing Nothing                                                      (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }@@ -919,25 +928,22 @@     : '{-# 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))}+    | '{-# WARNING' warning_category strings '#-}'+                         {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))+                                 (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}     |  {- empty -}                  { Nothing } -body    :: { (AnnList+body    :: { ([TrailingAnn]              ,([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)) }+        :  '{'            top '}'      { (fst $2, snd $2, explicitBraces $1 $3) }+        |      vocurly    top close    { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) } -body2   :: { (AnnList+body2   :: { ([TrailingAnn]              ,([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 '}'                          { (fst $2, snd $2, explicitBraces $1 $3) }+        |  missing_module_keyword top close     { ([], snd $2, VirtualBraces leftmostColumn) }   top     :: { ([TrailingAnn]@@ -956,14 +962,14 @@         : '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)+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] 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)+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs)                                                    NoLayoutInfo $3 Nothing)                                                 (Just $2) $4 $6 []                           ))) }@@ -1020,12 +1026,25 @@    -- 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))))) }+        : maybeexportwarning qcname_ext export_subspec {% do { let { span = (maybe comb2 (comb3 . reLoc) $1) (reLoc $2) $> }+                                                          ; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)+                                                          ; return $ unitOL $ reLocA $ sL span $ impExp } }+        | maybeexportwarning 'module' modid            {% do { let { span = (maybe comb2 (comb3 . reLoc) $1) $2 (reLoc $>)+                                                                   ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 (reLoc loc)) $1) $2 }+                                                          ; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3))+                                                          ; return $ unitOL $ reLocA $ locImpExp } }+        | maybeexportwarning 'pattern' qcon            { let span = (maybe comb2 (comb3 . reLoc) $1) $2 (reLoc $>)+                                                       in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 (reLocN $>) (IEPattern (glAA $2) $3)) } +maybeexportwarning :: { 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' warning_category strings '#-}'+                            {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))+                                (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}+        |  {- empty -}      { Nothing }+ export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }         : {- empty -}             { sL0 ([],ImpExpAbs) }         | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))@@ -1076,8 +1095,10 @@  -- 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 }+semis1  : semis1 ';'  { if isZeroWidthSpan (gl $2) then (sL1 $1 $ unLoc $1) else (sLL $1 $> $ AddSemiAnn (glAA $2) : (unLoc $1)) }+        | ';'         { case msemi $1 of+                          [] -> noLoc []+                          ms -> sL1 $1 $ ms }  -- Zero or more semicolons semis   :: { [TrailingAnn] }@@ -1158,13 +1179,40 @@         | {- empty -}              { noLoc Nothing }  impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) }-        :  '(' exportlist ')'               {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)+        :  '(' importlist ')'               {% 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)+        |  'hiding' '(' importlist ')'      {% 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)} } +importlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }+        : importlist1     { ([], $1) }+        | {- empty -}     { ([], nilOL) }++        -- trailing comma:+        | importlist1 ',' {% case $1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (gl $2)+                                 return ([], snocOL hs t')}+        | ','             { ([mj AnnComma $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 (gl $2)+                                           return (snocOL hs t' `appOL` $3)}+        | import          { $1 }++import  :: { OrdList (LIE GhcPs) }+        : qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL (reLoc $1) $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }+        | 'module' modid            {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (Nothing, EpAnn (glR $1) [mj AnnModule $1] cs) $2)) }+        | 'pattern' qcon            { unitOL $ reLocA $ sLL $1 (reLocN $>) $ IEVar Nothing (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2)) }+ ----------------------------------------------------------------------------- -- Fixity Declarations @@ -1938,6 +1986,11 @@ ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) +warning_category :: { Maybe (Located InWarningCategory) }+        : 'in' STRING                  { Just (sLL $1 $> $ InWarningCategory (hsTok' $1) (getSTRINGs $2)+                                                                             (sL1 $2 $ mkWarningCategory (getSTRING $2))) }+        | {- empty -}                  { Nothing }+ warnings :: { OrdList (LWarnDecl GhcPs) }         : warnings ';' warning         {% if isNilOL $1                                            then return ($1 `appOL` $3)@@ -1956,10 +2009,10 @@  -- 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))) }+        : warning_category namelist strings+                {% fmap unitOL $ acsA (\cs -> L (comb3M $1 $2 $3)+                     (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2)+                              (WarningTxt $1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }  deprecations :: { OrdList (LWarnDecl GhcPs) }         : deprecations ';' deprecation@@ -2197,7 +2250,7 @@         | ftype tyarg                   { $1 >>= \ $1 ->                                           mkHsAppTyPV $1 $2 }         | ftype PREFIX_AT atype         { $1 >>= \ $1 ->-                                          mkHsAppKindTyPV $1 (getLoc $2) $3 }+                                          mkHsAppKindTyPV $1 (hsTok $2) $3 }  tyarg :: { LHsType GhcPs }         : atype                         { $1 }@@ -2260,6 +2313,10 @@         | STRING               { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)                                                                      (getSTRING  $1) }         | '_'                  { reLocA $ sL1 $1 $ mkAnonWildCardTy }+        -- 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  acsa (\cs -> sL1a $1 (HsTyVar (EpAnn (glR $1) [] cs) 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@@ -3608,7 +3665,7 @@         | '(#' 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) []) }+                                       (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }         | '[' ']'               {% amsrn (sLL $1 $> $ listTyCon_RDR)                                        (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } @@ -3690,7 +3747,8 @@ op      :: { LocatedN RdrName }   -- used in infix decls         : varop                 { $1 }         | conop                 { $1 }-        | '->'                  { sL1n $1 $ getRdrName unrestrictedFunTyCon }+        | '->'                  {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                     (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }  varop   :: { LocatedN RdrName }         : varsym                { $1 }@@ -3865,6 +3923,22 @@                                                     $ 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)@@ -3905,45 +3979,61 @@ 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)+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+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+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+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+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+getLABELVARIDs    (L _ (ITlabelvarid src _)) = src --- See Note [Pragma source text] in "GHC.Types.Basic" for the following+-- 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@@ -4024,6 +4114,12 @@ comb3N a b c = a `seq` b `seq` c `seq`     combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c)) +comb3M :: Maybe (Located a) -> Located b -> Located c -> SrcSpan+comb3M (Just a) b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))+comb3M Nothing b c =  b `seq` c `seq`+    (combineSrcSpans (getLoc b) (getLoc 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) $@@ -4254,6 +4350,10 @@ glR :: Located a -> Anchor glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor +glMR :: Maybe (Located a) -> Located b -> Anchor+glMR (Just la) _ = glR la+glMR _ la = glR la+ glAA :: Located a -> EpaLocation glAA = srcSpan2e . getLoc @@ -4279,18 +4379,18 @@   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 :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a) acsFinal a = do-  let (L l _) = a emptyComments+  let (L l _) = a emptyComments Nothing   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))+             Strict.Nothing  -> Nothing+             Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)+  return (a (cs Semi.<> csf) ce) + acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a) acsa a = do   let (L l _) = a emptyComments@@ -4406,6 +4506,9 @@ hsTok :: Located Token -> LHsToken tok GhcPs hsTok (L l _) = L (mkTokenLocation l) HsTok +hsTok' :: Located Token -> Located (HsToken tok)+hsTok' (L l _) = L l HsTok+ hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs hsUniTok t@(L l _) =   L (mkTokenLocation l)@@ -4491,5 +4594,4 @@                 ->        Located (HsLocalBinds GhcPs,       EpAnnComments) adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments) adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)- }
compiler/GHC/Parser/Annotation.hs view
@@ -15,6 +15,7 @@   AddEpAnn(..),   EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,   TokenLocation(..),+  getTokenSrcSpan,   DeltaPos(..), deltaPos, getDeltaLine,    EpAnn(..), Anchor(..), AnchorOperation(..),@@ -412,6 +413,11 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation                deriving (Data,Eq) +getTokenSrcSpan :: TokenLocation -> SrcSpan+getTokenSrcSpan NoTokenLoc = noSrcSpan+getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan+getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos+ instance Outputable a => Outputable (GenLocated TokenLocation a) where   ppr (L _ x) = ppr x @@ -751,7 +757,10 @@       }   -- | Used for @->@, as an identifier   | NameAnnRArrow {+      nann_unicode   :: Bool,+      nann_mopen     :: Maybe EpaLocation,       nann_name      :: EpaLocation,+      nann_mclose    :: Maybe EpaLocation,       nann_trailing  :: [TrailingAnn]       }   -- | Used for an item with a leading @'@. The annotation for@@ -914,7 +923,7 @@ realSrcSpan (RealSrcSpan s _) = s realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary   where-    l = mkRealSrcLoc (fsLit "foo") (-1) (-1)+    l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)  srcSpan2e :: SrcSpan -> EpaLocation srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb@@ -1282,8 +1291,8 @@     = 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 (NameAnnRArrow u o n c t)+    = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t   ppr (NameAnnQuote q n t)     = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t   ppr (NameAnnTrailing t)
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -39,10 +39,9 @@  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@@ -430,14 +429,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@@ -626,7 +617,6 @@     PsErrAtInPatPos                               -> ErrorWithoutFlag     PsErrParseErrorOnInput{}                      -> ErrorWithoutFlag     PsErrMalformedDecl{}                          -> ErrorWithoutFlag-    PsErrUnexpectedTypeAppInDecl{}                -> ErrorWithoutFlag     PsErrNotADataCon{}                            -> ErrorWithoutFlag     PsErrInferredTypeVarNotAllowed                -> ErrorWithoutFlag     PsErrIllegalTraditionalRecordSyntax{}         -> ErrorWithoutFlag@@ -767,7 +757,6 @@     PsErrAtInPatPos                               -> noHints     PsErrParseErrorOnInput{}                      -> noHints     PsErrMalformedDecl{}                          -> noHints-    PsErrUnexpectedTypeAppInDecl{}                -> noHints     PsErrNotADataCon{}                            -> noHints     PsErrInferredTypeVarNotAllowed                -> noHints     PsErrIllegalTraditionalRecordSyntax{}         -> [suggestExtension LangExt.TraditionalRecordSyntax]
compiler/GHC/Parser/Errors/Types.hs view
@@ -68,7 +68,7 @@         arbitrary messages to be embedded. The typical use case would be GHC plugins         willing to emit custom diagnostics.     -}-    PsUnknownMessage UnknownDiagnostic+    PsUnknownMessage (UnknownDiagnostic (DiagnosticOpts PsMessage))      {-| A group of parser messages emitted in 'GHC.Parser.Header'.         See Note [Messages from GHC.Parser.Header].@@ -366,9 +366,6 @@     -- | Malformed ... declaration for ...    | PsErrMalformedDecl !SDoc !RdrName--   -- | Unexpected type application in a declaration-   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName     -- | Not a data constructor    | PsErrNotADataCon !RdrName
compiler/GHC/Parser/HaddockLex.x view
@@ -16,7 +16,6 @@ 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@@ -180,14 +179,7 @@                  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/Lexer.x view
@@ -42,6 +42,7 @@  { {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE UnboxedTuples #-}@@ -194,6 +195,10 @@ @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@@ -517,15 +522,15 @@ -- <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 }+  @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 }@@ -540,31 +545,116 @@   -- 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_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 }-  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 }+  @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 }    -- 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 }+  @negative @floating_point        \# / { negHashLitPred MagicHashBit }     { tok_frac 1 tok_primfloat }+  @negative @floating_point     \# \# / { negHashLitPred MagicHashBit }     { tok_frac 2 tok_primdouble }++  @decimal                  \#"Int8"   / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 0 decimal }+  @binarylit                \#"Int8"   / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint8 positive 2 binary }+  @octallit                 \#"Int8"   / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 2 octal }+  @hexadecimallit           \#"Int8"   / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 2 hexadecimal }+  @negative @decimal        \#"Int8"   / { negHashLitPred ExtendedLiteralsBit } { tok_primint8 negative 1 decimal }+  @negative @binarylit      \#"Int8"   / { negHashLitPred ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint8 negative 3 binary }+  @negative @octallit       \#"Int8"   / { negHashLitPred ExtendedLiteralsBit } { tok_primint8 negative 3 octal }+  @negative @hexadecimallit \#"Int8"   / { negHashLitPred ExtendedLiteralsBit } { tok_primint8 negative 3 hexadecimal }++  @decimal                  \#"Int16"  / { ifExtension ExtendedLiteralsBit } { tok_primint16 positive 0 decimal }+  @binarylit                \#"Int16"  / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint16 positive 2 binary }+  @octallit                 \#"Int16"  / { ifExtension ExtendedLiteralsBit } { tok_primint16 positive 2 octal }+  @hexadecimallit           \#"Int16"  / { ifExtension ExtendedLiteralsBit } { tok_primint16 positive 2 hexadecimal }+  @negative @decimal        \#"Int16"  / { negHashLitPred ExtendedLiteralsBit} { tok_primint16 negative 1 decimal }+  @negative @binarylit      \#"Int16"  / { negHashLitPred ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint16 negative 3 binary }+  @negative @octallit       \#"Int16"  / { negHashLitPred ExtendedLiteralsBit} { tok_primint16 negative 3 octal }+  @negative @hexadecimallit \#"Int16"  / { negHashLitPred ExtendedLiteralsBit} { tok_primint16 negative 3 hexadecimal }++  @decimal                  \#"Int32"  / { ifExtension ExtendedLiteralsBit } { tok_primint32 positive 0 decimal }+  @binarylit                \#"Int32"  / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint32 positive 2 binary }+  @octallit                 \#"Int32"  / { ifExtension ExtendedLiteralsBit } { tok_primint32 positive 2 octal }+  @hexadecimallit           \#"Int32"  / { ifExtension ExtendedLiteralsBit } { tok_primint32 positive 2 hexadecimal }+  @negative @decimal        \#"Int32"  / { negHashLitPred ExtendedLiteralsBit } { tok_primint32 negative 1 decimal }+  @negative @binarylit      \#"Int32"  / { negHashLitPred ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint32 negative 3 binary }+  @negative @octallit       \#"Int32"  / { negHashLitPred ExtendedLiteralsBit} { tok_primint32 negative 3 octal }+  @negative @hexadecimallit \#"Int32"  / { negHashLitPred ExtendedLiteralsBit} { tok_primint32 negative 3 hexadecimal }++  @decimal                  \#"Int64"  / { ifExtension ExtendedLiteralsBit } { tok_primint64 positive 0 decimal }+  @binarylit                \#"Int64"  / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint64 positive 2 binary }+  @octallit                 \#"Int64"  / { ifExtension ExtendedLiteralsBit } { tok_primint64 positive 2 octal }+  @hexadecimallit           \#"Int64"  / { ifExtension ExtendedLiteralsBit } { tok_primint64 positive 2 hexadecimal }+  @negative @decimal        \#"Int64"  / { negHashLitPred ExtendedLiteralsBit } { tok_primint64 negative 1 decimal }+  @negative @binarylit      \#"Int64"  / { negHashLitPred ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint64 negative 3 binary }+  @negative @octallit       \#"Int64"  / { negHashLitPred ExtendedLiteralsBit } { tok_primint64 negative 3 octal }+  @negative @hexadecimallit \#"Int64"  / { negHashLitPred ExtendedLiteralsBit } { tok_primint64 negative 3 hexadecimal }++  @decimal                  \#"Int"    / { ifExtension ExtendedLiteralsBit } { tok_primint positive 0 4 decimal }+  @binarylit                \#"Int"    / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint positive 2 6 binary }+  @octallit                 \#"Int"    / { ifExtension ExtendedLiteralsBit } { tok_primint positive 2 6 octal }+  @hexadecimallit           \#"Int"    / { ifExtension ExtendedLiteralsBit } { tok_primint positive 2 6 hexadecimal }+  @negative @decimal        \#"Int"    / { negHashLitPred ExtendedLiteralsBit } { tok_primint negative 1 5 decimal }+  @negative @binarylit      \#"Int"    / { negHashLitPred ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primint negative 3 7 binary }+  @negative @octallit       \#"Int"    / { negHashLitPred ExtendedLiteralsBit } { tok_primint negative 3 7 octal }+  @negative @hexadecimallit \#"Int"    / { negHashLitPred ExtendedLiteralsBit } { tok_primint negative 3 7 hexadecimal }++  @decimal                  \#"Word8"  / { ifExtension ExtendedLiteralsBit } { tok_primword8 0 decimal }+  @binarylit                \#"Word8"  / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primword8 2 binary }+  @octallit                 \#"Word8"  / { ifExtension ExtendedLiteralsBit } { tok_primword8 2 octal }+  @hexadecimallit           \#"Word8"  / { ifExtension ExtendedLiteralsBit } { tok_primword8 2 hexadecimal }++  @decimal                  \#"Word16" / { ifExtension ExtendedLiteralsBit } { tok_primword16 0 decimal }+  @binarylit                \#"Word16" / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primword16 2 binary }+  @octallit                 \#"Word16" / { ifExtension ExtendedLiteralsBit } { tok_primword16 2 octal }+  @hexadecimallit           \#"Word16" / { ifExtension ExtendedLiteralsBit } { tok_primword16 2 hexadecimal }++  @decimal                  \#"Word32" / { ifExtension ExtendedLiteralsBit } { tok_primword32 0 decimal }+  @binarylit                \#"Word32" / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primword32 2 binary }+  @octallit                 \#"Word32" / { ifExtension ExtendedLiteralsBit } { tok_primword32 2 octal }+  @hexadecimallit           \#"Word32" / { ifExtension ExtendedLiteralsBit } { tok_primword32 2 hexadecimal }++  @decimal                  \#"Word64" / { ifExtension ExtendedLiteralsBit } { tok_primword64 0 decimal }+  @binarylit                \#"Word64" / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primword64 2 binary }+  @octallit                 \#"Word64" / { ifExtension ExtendedLiteralsBit } { tok_primword64 2 octal }+  @hexadecimallit           \#"Word64" / { ifExtension ExtendedLiteralsBit } { tok_primword64 2 hexadecimal }++  @decimal                  \#"Word"   / { ifExtension ExtendedLiteralsBit } { tok_primword 0 5 decimal }+  @binarylit                \#"Word"   / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit }   { tok_primword 2 7 binary }+  @octallit                 \#"Word"   / { ifExtension ExtendedLiteralsBit } { tok_primword 2 7 octal }+  @hexadecimallit           \#"Word"   / { ifExtension ExtendedLiteralsBit } { tok_primword 2 7 hexadecimal }+ }  -- Strings and chars are lexed by hand-written code.  The reason is@@ -771,7 +861,7 @@   | ITdependency   | ITrequires -  -- Pragmas, see  Note [Pragma source text] in "GHC.Types.Basic"+  -- Pragmas, see  Note [Pragma source text] in "GHC.Types.SourceText"   | ITinline_prag       SourceText InlineSpec RuleMatchInfo   | ITopaque_prag       SourceText   | ITspec_prag         SourceText                -- SPECIALISE@@ -855,17 +945,25 @@   | 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"+                                         -- Note [Literal source text] in "GHC.Types.SourceText" -  | 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"+  | ITchar     SourceText Char       -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITstring   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.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"+  | 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 @@ -918,18 +1016,11 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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.+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 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?+We also use this to track the space before the end-of-file marker. -}  {- Note [Minus tokens]@@ -1125,7 +1216,7 @@  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))+  = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1))                         (lexemeToFastString (stepOn buf) (len-1)))  skip_two_varid :: (FastString -> Token) -> Action@@ -1136,6 +1227,10 @@ 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 @@ -1288,10 +1383,10 @@       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+negHashLitPred :: ExtBits -> AlexAccPred ExtsBitmap+negHashLitPred ext = prefix_minus `alexAndPred` magic_hash   where-    magic_hash = ifExtension MagicHashBit+    magic_hash = ifExtension ext -- Either MagicHashBit or ExtendedLiteralsBit     prefix_minus =       -- Note [prefix_minus in negLitPred and negHashLitPred]       alexNotPred precededByClosingToken@@ -1370,7 +1465,7 @@ lineCommentToken span buf len buf2 = do   b <- getBit RawTokenStreamBit   if b then do-         lt <- getLastLocComment+         lt <- getLastLocIncludingComments          strtoken (\s -> ITlineComment s lt) span buf len buf2        else lexToken @@ -1381,7 +1476,7 @@ -} nested_comment :: Action nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do-  l <- getLastLocComment+  l <- getLastLocIncludingComments   let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span   input <- getInput   -- Include decorator in comment@@ -1391,7 +1486,7 @@ 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))+    worker input docType _checkNextLine = nested_comment_logic endComment "" input span       where         endComment input lcomment           = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span@@ -1485,7 +1580,7 @@                  -> P (PsLocated Token) withLexedDocType lexDocComment = do   input@(AI _ buf) <- getInput-  l <- getLastLocComment+  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.@@ -1530,7 +1625,7 @@ rulePrag :: Action rulePrag span buf len _buf2 = do   setExts (.|. xbit InRulePragBit)-  let !src = lexemeToString buf len+  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@@ -1540,7 +1635,7 @@   usePosPrags <- getBit UsePosPragsBit   if usePosPrags     then begin line_prag2 span buf len buf2-    else let !src = lexemeToString buf len+    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@@ -1548,10 +1643,9 @@ 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+    else let !src = lexemeToFastString buf len          in return (L span (ITcolumn_prag (SourceText src)))  endPrag :: Action@@ -1798,8 +1892,8 @@              -> 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+  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@@ -1811,7 +1905,7 @@         -> Int -> Int         -> (Integer, (Char->Int)) -> Action tok_num = tok_integral $ \case-    st@(SourceText ('-':_)) -> itint st (const True)+    st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True)     st@(SourceText _)       -> itint st (const False)     st@NoSourceText         -> itint st (< 0)   where@@ -1836,6 +1930,40 @@ octal = (8,octDecDigit) hexadecimal = (16,hexDigit) +-- | Helper for defining @IntX@ primitive literal parsers (specifically for+--   the ExtendedLiterals extension, such as @123#Int8@).+tok_primintX :: (SourceText -> Integer -> Token)+             -> Int+             -> (Integer -> Integer)+             -> Int+             -> (Integer, (Char->Int)) -> Action+tok_primintX itint addlen transint transbuf =+    tok_integral itint transint transbuf (transbuf+addlen)++tok_primint8,     tok_primint16,  tok_primint32,  tok_primint64+    :: (Integer -> Integer)+    -> Int -> (Integer, (Char->Int)) -> Action+tok_primint8  = tok_primintX ITprimint8   5+tok_primint16 = tok_primintX ITprimint16  6+tok_primint32 = tok_primintX ITprimint32  6+tok_primint64 = tok_primintX ITprimint64  6++-- | Helper for defining @WordX@ primitive literal parsers (specifically for+--   the ExtendedLiterals extension, such as @234#Word8@).+tok_primwordX :: (SourceText -> Integer -> Token)+              -> Int+              -> Int+              -> (Integer, (Char->Int)) -> Action+tok_primwordX itint addlen transbuf =+    tok_integral itint positive transbuf (transbuf+addlen)++tok_primword8, tok_primword16, tok_primword32, tok_primword64+    :: Int -> (Integer, (Char->Int)) -> Action+tok_primword8  = tok_primwordX ITprimword8  6+tok_primword16 = tok_primwordX ITprimword16 7+tok_primword32 = tok_primwordX ITprimword32 7+tok_primword64 = tok_primwordX ITprimword64 7+ -- readSignificandExponentPair can understand negative rationals, exponents, everything. tok_frac :: Int -> (String -> Token) -> Action tok_frac drop f span buf len _buf2 = do@@ -2008,7 +2136,7 @@ lex_string_prag_comment mkTok span _buf _len _buf2     = do input <- getInput          start <- getParsedLoc-         l <- getLastLocComment+         l <- getLastLocIncludingComments          tok <- go l [] input          end <- getParsedLoc          return (L (mkPsSpan start end) tok)@@ -2041,7 +2169,7 @@     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)+    src = lexemeToFastString buf (cur bufEnd - cur buf)   return $ L (mkPsSpan (psSpanStart span) end) tok  @@ -2052,7 +2180,7 @@   (AI end bufEnd) <- getInput   let     token = ITlabelvarid (SourceText src) (mkFastString s)-    src = lexemeToString (stepOn buf) (cur bufEnd - cur buf - 1)+    src = lexemeToFastString (stepOn buf) (cur bufEnd - cur buf - 1)     start = psSpanStart span    return $ L (mkPsSpan start end) token@@ -2177,13 +2305,13 @@                         -- Just need to check for trailing #   = do  magicHash <- getBit MagicHashBit         i@(AI end bufEnd) <- getInput-        let src = lexemeToString buf (cur bufEnd - cur buf)+        let src = lexemeToFastString 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)+                let src' = lexemeToFastString buf (cur bufEnd' - cur buf)                 return (L (mkPsSpan loc end)                           (ITprimchar (SourceText src') ch))               _other ->@@ -2502,9 +2630,7 @@         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]+        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)@@ -2632,24 +2758,21 @@   } ()  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} ()+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-                                         , prev_loc2 = prev_loc s} ()+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]-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+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@@ -2915,6 +3038,7 @@   | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]   | OverloadedRecordDotBit   | OverloadedRecordUpdateBit+  | ExtendedLiteralsBit    -- Flags that are updated once parsing starts   | InRulePragBit@@ -2994,6 +3118,7 @@       .|. 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).+      .|. ExtendedLiteralsBit         `xoptBit` LangExt.ExtendedLiterals     optBits =           HaddockBit        `setBitIf` isHaddock       .|. RawTokenStreamBit `setBitIf` rawTokStream@@ -3032,7 +3157,6 @@       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,@@ -3506,8 +3630,8 @@   case alexScanUser exts inp sc of     AlexEOF -> do         let span = mkPsSpan loc1 loc1-        lt <- getLastLocEof-        setEofPos (psRealSpan span) (psRealSpan lt)+        lc <- getLastLocIncludingComments+        setEofPos (psRealSpan span) (psRealSpan lc)         setLastToken span 0         return (L span ITeof)     AlexError (AI loc2 buf) ->@@ -3571,42 +3695,42 @@ oneWordPrags = Map.fromList [      ("rules", rulePrag),      ("inline",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),      ("inlinable",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),      ("inlineable",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),+         fstrtoken (\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))),+         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",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),      ("notinline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),+         fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),      ("specialize inline",-         strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),+         fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))),      ("specialize notinline",-         strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))+         fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False)))      ]  dispatch_pragmas :: Map String Action -> Action@@ -3692,14 +3816,19 @@   -> ([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+    -- 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 (anchor l) == 1+          && srcSpanEndLine (ac_prior_tok c) /= srcSpanStartLine (anchor l) -    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)+    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) (anchor l) cs+                              else (reverse (c:cs), decl_comments)   in     go [] ss prior_comments @@ -3713,10 +3842,7 @@     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+    (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/PostProcess.hs view
@@ -153,6 +153,7 @@ import Data.List        ( findIndex ) import Data.Foldable import qualified Data.Semigroup as Semi+import GHC.Unit.Module.Warnings import GHC.Utils.Panic import GHC.Utils.Panic.Plain import qualified GHC.Data.Strict as Strict@@ -890,42 +891,52 @@   = 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 (HsTypeArg at ki) = chkParens [] [] emptyComments (HsBndrInvisible at) ki+    check (HsValArg ty) = chkParens [] [] emptyComments HsBndrRequired 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))+    chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs+              -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)+    chkParens ops cps cs bvis (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+          chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) bvis ty+    chkParens ops cps cs bvis ty = chk ops cps cs bvis 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))+    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)+    chk ops cps cs bvis (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)))+                return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))+                       (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs)+                                    bvis (L lv tv) k))+    chk ops cps cs bvis (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 _)+                return (L (widenLocatedAn l (for_widening bvis:an))+                                     (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs)+                                                bvis (L ltv tv)))+    chk _ _ _ _ t@(L loc _)         = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $             (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) +    -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.+    for_widening :: HsBndrVis GhcPs -> AddEpAnn+    for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc+    for_widening  _                                     = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) []) +    for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]+    for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments+    for_widening_ann  _                                     = EpAnnNotUsed++ whereDots, equalsDots :: SDoc -- Second argument to checkTyVars whereDots  = text "where ..."@@ -1020,7 +1031,7 @@       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 _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at 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)@@ -1817,11 +1828,6 @@ 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@@ -1957,7 +1963,7 @@   -- | 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)+  mkHsAppKindTyPV :: LocatedA b -> LHsToken "@" GhcPs -> 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)@@ -1966,7 +1972,7 @@ 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)+  mkHsAppKindTyPV t at ki = return (mkHsAppKindTy t at ki)   mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)   mkUnpackednessPV = addUnpackednessP @@ -2002,8 +2008,8 @@     -- the grammar in Parser.y is written (see infixtype/ftype).     panic "mkHsAppTyPV: InfixDataConBuilder" -  mkHsAppKindTyPV lhs l_at ki =-    addFatalError $ mkPlainErrorMsgEnvelope l_at $+  mkHsAppKindTyPV lhs at ki =+    addFatalError $ mkPlainErrorMsgEnvelope (getTokenSrcSpan (getLoc at)) $                       (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))    mkHsOpTyPV prom lhs tc rhs = do@@ -2528,7 +2534,7 @@   -- 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' :: [LHsRecUpdField GhcPs GhcPs]       fs' = map (fmap mk_rec_upd_field) fs   case overloaded_on of     False | not $ null ps ->@@ -2539,19 +2545,27 @@       return RecordUpd {         rupd_ext = anns       , rupd_expr = exp-      , rupd_flds = Left fs' }+      , 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 . rdrNameAmbiguousFieldOcc $ lbl+                      , isQual . ambiguousFieldOccRdrName $ 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) }+                  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 })@@ -2583,7 +2597,7 @@ 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 :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)   = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun @@ -2592,7 +2606,7 @@ -- 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+  = InlinePragma { inl_src = src -- Note [Pragma source text] in "GHC.Types.SourceText"                  , inl_inline = inl                  , inl_sat    = Nothing                  , inl_act    = act@@ -2714,7 +2728,8 @@              ((mk Nothing <$> cimp nm) +++               (do h <- munch1 hdr_char                   skipSpaces-                  mk (Just (Header (SourceText h) (mkFastString h)))+                  let src = mkFastString h+                  mk (Just (Header (SourceText src) src))                       <$> cimp nm))          ]        skipSpaces@@ -2788,18 +2803,20 @@                   | ImpExpQcType EpaLocation (LocatedN RdrName)                   | ImpExpQcWildcard -mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)-mkModuleImpExp anns (L l specname) subs = do+mkModuleImpExp :: Maybe (LocatedP (WarningTxt GhcPs)) -> [AddEpAnn] -> LocatedA ImpExpQcSpec+               -> ImpExpSubSpec -> P (IE GhcPs)+mkModuleImpExp warning anns (L l specname) subs = do   cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments-  let ann = EpAnn (spanAsAnchor $ locA l) anns cs+  let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) 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+                       -> return $ IEVar warning+                           (L l (ieNameFromSpec specname))+      | otherwise      -> IEThingAbs (warning, ann) . L l <$> nameT+    ImpExpAll          -> IEThingAll (warning, ann) . L l <$> nameT     ImpExpList xs      ->-      (\newName -> IEThingWith ann (L l newName)+      (\newName -> IEThingWith (warning, ann) (L l newName)         NoIEWildcard (wrapped xs)) <$> nameT     ImpExpAllWith xs                       ->       do allowed <- getBit PatternSynonymsBit@@ -2811,7 +2828,7 @@                 ies :: [LocatedA (IEWrappedName GhcPs)]                 ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs             in (\newName-                        -> IEThingWith ann (L l newName) pos ies)+                        -> IEThingWith (warning, ann) (L l newName) pos ies)                <$> nameT           else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $                  PsErrIllegalPatSynExport@@ -3113,7 +3130,7 @@   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+mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr   -- See #18888 for the use of (SourceText "1") above   = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)   where
compiler/GHC/Parser/Types.hs view
@@ -61,6 +61,12 @@   | PatBuilderVar (LocatedN RdrName)   | PatBuilderOverLit (HsOverLit GhcPs) +-- These instances are here so that they are not orphans+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 Outputable (PatBuilder GhcPs) where   ppr (PatBuilderPat p) = ppr p   ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p)
compiler/GHC/Platform.hs view
@@ -29,6 +29,7 @@    , platformInIntRange    , platformInWordRange    , platformCConvNeedsExtension+   , platformHasRTSLinker    , PlatformMisc(..)    , SseVersion (..)    , BmiVersion (..)@@ -271,6 +272,23 @@       -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms     | 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+  ArchRISCV64       -> False+  ArchLoongArch64   -> False+  ArchJavaScript    -> False+  ArchWasm32        -> False+  _                 -> True+   --------------------------------------------------
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@@ -19,6 +22,7 @@   ,Applicative (..)   ,module Bits   ,shiftL, shiftR+  ,head, tail   ) where  @@ -50,9 +54,11 @@     extensions. -} -import Prelude as X hiding ((<>), Applicative(..))+import qualified Prelude+import Prelude as X hiding ((<>), Applicative(..), head, tail) import Control.Applicative (Applicative(..)) import Data.Foldable as X (foldl')+import GHC.Stack.Types (HasCallStack)  #if MIN_VERSION_base(4,16,0) import GHC.Bits as Bits hiding (shiftL, shiftR)@@ -102,3 +108,21 @@ shiftL = Bits.unsafeShiftL shiftR = Bits.unsafeShiftR #endif++{- 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 #-}
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,6 @@ import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Types.Avail import GHC.Types.Fixity.Env import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name@@ -94,7 +94,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@@ -185,10 +185,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 +199,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@@ -328,7 +330,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 +345,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)@@ -400,8 +401,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 +413,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 +429,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/Heap/Layout.hs view
@@ -175,7 +175,7 @@   | RTSRep              -- The RTS needs to declare info tables with specific         Int             -- type tags, so this form lets us override the default         SMRep           -- tag for an SMRep.-  deriving (Eq, Ord)+  deriving Eq  -- | True \<=> This is a static closure.  Affects how we garbage-collect it. -- Static closure have an extra static link field at the end.@@ -193,7 +193,7 @@   | ThunkSelector SelectorOffset   | BlackHole   | IndStatic-  deriving (Eq, Ord)+  deriving Eq  type ConstrDescription = ByteString -- result of dataConIdentity type FunArity          = Int@@ -223,7 +223,7 @@   | ArgUnknown          -- For imported binds.                         -- Invariant: Never Unknown for binds of the module                         -- we are compiling.-  deriving (Eq, Ord)+  deriving (Eq)  instance Outputable ArgDescr where   ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
− 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
@@ -4,10 +4,22 @@ module GHC.Runtime.Interpreter.Types    ( Interp(..)    , InterpInstance(..)-   , IServ(..)-   , IServInstance(..)+   , InterpProcess (..)+   , ExtInterp (..)+   , ExtInterpStatusVar+   , ExtInterpInstance (..)+   , ExtInterpState (..)+   , InterpStatus(..)+   -- * IServ+   , IServ    , IServConfig(..)-   , IServState(..)+   -- * JSInterp+   , JSInterp+   , JSInterpExtra (..)+   , JSInterpConfig (..)+   , JSState (..)+   , NodeJsSettings (..)+   , defaultNodeJsSettings    ) where @@ -20,8 +32,17 @@ import GHC.Data.FastString ( FastString ) import Foreign +import GHC.Utils.TmpFs+import GHC.Utils.Logger+import GHC.Unit.Env+import GHC.Unit.Types+import GHC.StgToJS.Types+import GHC.StgToJS.Linker.Types+ import Control.Concurrent import System.Process   ( ProcessHandle, CreateProcess )+import System.IO+import GHC.Unit.Finder.Types (FinderCache, FinderOpts)  -- | Interpreter data Interp = Interp@@ -32,25 +53,41 @@       -- ^ Interpreter loader   } - 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+ -- | 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++data InterpProcess = InterpProcess+  { interpPipe   :: !Pipe           -- ^ Pipe to communicate with the server+  , interpHandle :: !ProcessHandle  -- ^ Process handle of the server+  }++-- | 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 +98,66 @@   , 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.++  , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))+      -- ^ LookupSymbol cache++  , instExtra             :: !c+      -- ^ Instance specific extra fields+  }++------------------------+-- 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   }
compiler/GHC/Settings.hs view
@@ -19,6 +19,7 @@   , sGlobalPackageDatabasePath   , sLdSupportsCompactUnwind   , sLdSupportsFilelist+  , sLdSupportsResponseFiles   , sLdIsGnuLd   , sGccSupportsNoPie   , sUseInplaceMinGW@@ -87,7 +88,7 @@ data ToolSettings = ToolSettings   { toolSettings_ldSupportsCompactUnwind :: Bool   , toolSettings_ldSupportsFilelist      :: Bool-  , toolSettings_ldSupportsSingleModule  :: Bool+  , toolSettings_ldSupportsResponseFiles :: Bool   , toolSettings_ldIsGnuLd               :: Bool   , toolSettings_ccSupportsNoPie         :: Bool   , toolSettings_useInplaceMinGW         :: Bool@@ -190,6 +191,8 @@ sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings+sLdSupportsResponseFiles :: Settings -> Bool+sLdSupportsResponseFiles = toolSettings_ldSupportsResponseFiles . sToolSettings sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool
compiler/GHC/Settings/Constants.hs view
@@ -30,6 +30,27 @@ mAX_SOLVER_ITERATIONS :: Int mAX_SOLVER_ITERATIONS = 4 +-- | In case of loopy quantified costraints 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/InferTags/TagSig.hs view
@@ -13,11 +13,21 @@ 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@@ -45,11 +55,6 @@                           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 '>'
+ 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 declartions 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
@@ -68,28 +68,37 @@  import GHC.Prelude -import GHC.Core     ( AltCon )+import GHC.Stg.InferTags.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(..), 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.Types.RepType ( typePrimRep1, typePrimRep )+ import GHC.Unit.Module       ( Module ) import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain+ 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 Data.ByteString ( ByteString )+import Data.Data   ( Data )+import Data.List   ( intersperse )+ {- ************************************************************************ *                                                                      *@@ -165,10 +174,9 @@ -- -- The coercion argument here gets VoidRep isAddrRep :: PrimRep -> Bool-isAddrRep AddrRep     = True-isAddrRep LiftedRep   = True-isAddrRep UnliftedRep = True-isAddrRep _           = False+isAddrRep AddrRep      = True+isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript+isAddrRep _            = False  -- | Type of an @StgArg@ --@@ -228,6 +236,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,7 +290,7 @@         -- which can't be let-bound   | StgConApp   DataCon                 ConstructorNumber-                [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg])+                [StgArg] -- Saturated. See Note [Constructor applications in STG]                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise    | StgOpApp    StgOp    -- Primitive op or foreign call@@ -384,6 +438,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 +467,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 +486,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  {- ************************************************************************@@ -600,25 +656,34 @@   | 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  {- @@ -874,14 +939,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/Config.hs view
@@ -11,6 +11,7 @@ import GHC.Utils.Outputable import GHC.Utils.TmpFs +import GHC.Cmm.MachOp ( FMASign(..) ) import GHC.Prelude  @@ -49,9 +50,8 @@   , stgToCmmFastPAPCalls   :: !Bool              -- ^   , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled   , stgToCmmEagerBlackHole :: !Bool              -- ^-  , 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+  , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See note [Mapping+                                                 -- Info Tables to Source Positions]   , stgToCmmOmitYields     :: !Bool              -- ^ true means omit heap checks when no allocation is performed   , stgToCmmOmitIfPragmas  :: !Bool              -- ^ true means don't generate interface programs (implied by -O0)   , stgToCmmPIC            :: !Bool              -- ^ true if @-fPIC@@@ -67,6 +67,7 @@   , stgToCmmAllowQuotRem2             :: !Bool   -- ^ Allowed to generate QuotRem   , stgToCmmAllowExtendedAddSubInstrs :: !Bool   -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc.   , stgToCmmAllowIntMul2Instr         :: !Bool   -- ^ Allowed to generate IntMul2 instruction+  , stgToCmmAllowFMAInstr             :: FMASign -> Bool -- ^ Allowed to generate FMA instruction   , stgToCmmTickyAP                   :: !Bool   -- ^ Disable use of precomputed standard thunks.   ------------------------------ SIMD flags ------------------------------------   -- Each of these flags checks vector compatibility with the backend requested
compiler/GHC/StgToCmm/Types.hs view
@@ -53,7 +53,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 +75,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 +125,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,100 @@+{-# 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 (..)+  , defaultJSLinkConfig+  , LinkedObj (..)+  , LinkPlan (..)+  )+where++import GHC.StgToJS.Object++import GHC.Unit.Types+import GHC.Utils.Outputable (hsep,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+  }++-- | Default linker configuration+defaultJSLinkConfig :: JSLinkConfig+defaultJSLinkConfig = JSLinkConfig+  { lcNoJSExecutables = False+  , lcNoHsMain        = False+  , lcNoRts           = False+  , lcNoStats         = False+  , lcCombineAll      = True+  , lcForeignRefs     = True+  }++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 sources from++  , lkp_extra_js   :: Set FilePath+      -- ^ Extra JS files 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 "JS files from archives:") 2 (vcat (fmap text (S.toList (lkp_archives s))))+            , hang (text "Extra JS:") 2 (vcat (fmap text (S.toList (lkp_extra_js s))))+            ]++--------------------------------------------------------------------------------+-- Linker Environment+--------------------------------------------------------------------------------++-- | An object file that's either already in memory (with name) or on disk+data LinkedObj+  = ObjFile   FilePath      -- ^ load from this file+  | ObjLoaded String Object -- ^ already loaded: description and payload++instance Outputable LinkedObj where+  ppr = \case+    ObjFile fp    -> hsep [text "ObjFile", text fp]+    ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)]
+ compiler/GHC/StgToJS/Object.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}++-- 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+--  The .o files contain dependency information and generated code.+--  All strings are mapped to a central string table, which helps reduce+--  file size and gives us efficient hash consing on read+--+--  Binary intermediate JavaScript object files:+--   serialized [Text] -> ([ClosureInfo], JStat) blocks+--+--  file layout:+--   - magic "GHCJSOBJ"+--   - compiler version tag+--   - module name+--   - offsets of string table+--   - dependencies+--   - offset of the index+--   - unit infos+--   - index+--   - string table+--+-----------------------------------------------------------------------------++module GHC.StgToJS.Object+  ( putObject+  , getObjectHeader+  , getObjectBody+  , getObject+  , readObject+  , getObjectBlocks+  , readObjectBlocks+  , readObjectBlockInfo+  , isGlobalBlock+  , isJsObjectFile+  , Object(..)+  , IndexEntry(..)+  , LocatedBlockInfo (..)+  , BlockInfo (..)+  , BlockDeps (..)+  , BlockLocation (..)+  , BlockId+  , BlockIds+  , BlockRef (..)+  , ExportedFun (..)+  )+where++import GHC.Prelude++import           Control.Monad++import           Data.Array+import           Data.Int+import           Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import           Data.List (sortOn)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Word+import           Data.Char+import Foreign.Storable+import Foreign.Marshal.Array+import System.IO++import GHC.Settings.Constants (hiVersion)++import GHC.JS.Unsat.Syntax+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)++-- | An object file+data Object = Object+  { objModuleName    :: !ModuleName+    -- ^ name of the module+  , objHandle        :: !BinHandle+    -- ^ 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 :: BinHandle -> ObjBlock -> IO ()+putObjBlock bh (ObjBlock _syms b c d e f g) = do+    put_ bh b+    put_ bh c+    lazyPut bh d+    put_ bh e+    put_ bh f+    put_ bh g++-- | Read an ObjBlock and associate it to the given symbols (that must have been+-- read from the index)+getObjBlock :: [FastString] -> BinHandle -> IO ObjBlock+getObjBlock syms bh = do+    b <- get bh+    c <- get bh+    d <- lazyGet bh+    e <- get bh+    f <- get bh+    g <- get bh+    pure $ ObjBlock+      { oiSymbols  = syms+      , oiClInfo   = b+      , oiStatic   = c+      , oiStat     = d+      , oiRaw      = e+      , oiFExports = f+      , oiFImports = g+      }+++-- | A tag that determines the kind of payload in the .o file. See+-- @StgToJS.Linker.Arhive.magic@ for another kind of magic+magic :: String+magic = "GHCJSOBJ"++-- | 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 oeprations 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+  :: BinHandle+  -> ModuleName -- ^ module+  -> BlockInfo  -- ^ block infos+  -> [ObjBlock] -- ^ linkable units and their symbols+  -> IO ()+putObject bh mod_name deps os = do+  forM_ magic (putByte bh . fromIntegral . ord)+  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)++  (bh_fs, _bin_dict, put_dict) <- initFSTable bh++  forwardPut_ bh (const put_dict) $ do+    put_ bh_fs deps++    -- forward put the index+    forwardPut_ bh_fs (put_ bh_fs) $ do+      idx <- forM os $ \o -> do+        p <- tellBin 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++-- | Test if the object file is a JS object+isJsObjectFile :: FilePath -> IO Bool+isJsObjectFile fp = do+  let !n = length magic+  withBinaryFile fp ReadMode $ \hdl -> do+    allocaArray n $ \ptr -> do+      n' <- hGetBuf hdl ptr n+      if (n' /= n)+        then pure False+        else checkMagic (peekElemOff ptr)++-- | Check magic+checkMagic :: (Int -> IO Word8) -> IO Bool+checkMagic get_byte = do+  let go_magic !i = \case+        []     -> pure True+        (e:es) -> get_byte i >>= \case+          c | fromIntegral (ord e) == c -> go_magic (i+1) es+            | otherwise                 -> pure False+  go_magic 0 magic++-- | Parse object magic+getCheckMagic :: BinHandle -> IO Bool+getCheckMagic bh = checkMagic (const (getByte bh))++-- | Parse object header+getObjectHeader :: BinHandle -> IO (Either String ModuleName)+getObjectHeader bh = do+  is_magic <- getCheckMagic bh+  case is_magic of+    False -> pure (Left "invalid magic header")+    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 sucessful getObjectHeader+getObjectBody :: BinHandle -> ModuleName -> IO Object+getObjectBody bh0 mod_name = do+  -- Read the string table+  dict <- forwardGet bh0 (getDictionary bh0)+  let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict }++  block_info  <- get bh+  idx         <- forwardGet bh (get bh)+  payload_pos <- tellBin bh++  pure $ Object+    { objModuleName    = mod_name+    , objHandle        = bh+    , objPayloadOffset = payload_pos+    , objBlockInfo     = block_info+    , objIndex         = idx+    }++-- | Parse object+getObject :: BinHandle -> 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+          seekBin 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 => BinHandle -> 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 => BinHandle -> 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.JHash m)     = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)+  put_ bh (Sat.JFunc is s)  = putByte bh 8 >> 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.JHash . listToUniqMap <$> get bh+    8 -> Sat.JFunc   <$> get bh <*> get bh+    n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n)++instance Binary Ident where+  put_ bh (TxtI xs) = put_ bh xs+  get bh = TxtI <$> 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 VarType 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 (StaticFun f args)   = putByte bh 1 >> put_ bh f  >> put_ bh args+  put_ bh (StaticThunk t)      = putByte bh 2 >> put_ bh t+  put_ bh (StaticUnboxed u)    = putByte bh 3 >> put_ bh u+  put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args+  put_ bh (StaticList xs t)    = putByte bh 5 >> put_ bh xs >> put_ bh t+  get bh = getByte bh >>= \case+    1 -> StaticFun     <$> get bh <*> get bh+    2 -> StaticThunk   <$> get bh+    3 -> StaticUnboxed <$> get bh+    4 -> StaticData    <$> 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)
+ compiler/GHC/StgToJS/Types.hs view
@@ -0,0 +1,419 @@+{-# 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.Unsat.Syntax+import qualified GHC.JS.Syntax as Sat+import GHC.JS.Make+import GHC.JS.Ppr ()++import GHC.Stg.Syntax+import GHC.Core.TyCon++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 qualified Data.Map as M+import           Data.Set (Set)+import qualified Data.ByteString as BS+import           Data.Monoid++-- | 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    :: [JStat]                -- ^ 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 :: [JStat]        -- ^ 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+  }++-- | Information relevenat to code generation for closures.+data ClosureInfo = ClosureInfo+  { ciVar     :: Ident      -- ^ object being infod+  , 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 :: [VarType] -- ^ 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     :: [VarType] -- ^ The set of sized Types 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 TxtI rs)++-- | Free variable types+data VarType+  = 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 VarType 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$baseZCGHCziMaybeziJust_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$baseZCGHCziMaybeziJust_e() {+--    var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2;+--    h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_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 !Int !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 StaticVal+  = StaticFun     !FastString [StaticArg]+    -- ^ heap object for function+  | StaticThunk   !(Maybe (FastString,[StaticArg]))+    -- ^ heap object for CAF (field is Nothing when thunk is initialized in an+    -- alternative way, like string thunks through h$str)+  | StaticUnboxed !StaticUnboxed+    -- ^ unboxed constructor (Bool, Int, Double etc)+  | StaticData    !FastString [StaticArg]+    -- ^ regular datacon app+  | StaticList    [StaticArg] (Maybe FastString)+    -- ^ list initializer (with optional tail)+  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 (mkFastString "h$str") [toJExpr t]+  toJExpr (BinLit b)            = app (mkFastString "h$rstr") [toJExpr (map toInteger (BS.unpack b))]+  toJExpr (LabelLit _isFun lbl) = var lbl++-- | A foreign reference to some JS code+data ForeignJSRef = ForeignJSRef+  { foreignRefSrcSpan  :: !FastString+  , foreignRefPattern  :: !FastString+  , foreignRefSafety   :: !Safety+  , foreignRefCConv    :: !CCallConv+  , foreignRefArgs     :: ![FastString]+  , foreignRefResult   :: !FastString+  }++-- | 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 :: [JExpr]+  }++-- FIXME: temporarily removed until JStg replaces JStat+-- instance Outputable TypedExpr where+--   ppr x = text "TypedExpr: " <+> ppr (typex_expr x)+--           $$  text "PrimReps: " <+> ppr (typex_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 JStat  -- ^ primop is inline, result is assigned directly+  | PRPrimCall JStat  -- ^ primop is async call, primop returns the next+                      -- function to run. result returned to stack top in+                      -- registers++data ExprResult+  = ExprCont+  | ExprInline (Maybe [JExpr])+  deriving (Eq)++newtype ExprValData = ExprValData [JExpr]+  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)++-- | 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++-- | 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/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 (..),   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@@ -126,25 +124,3 @@ 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,3 @@+module GHC.Tc.Errors.Hole.Plugin where++data HoleFitPlugin
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -20,4104 +20,6492 @@   , 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"+  , pprTyThingUsedWrong+  , pprUntouchableVariable++  -- | Useful when overriding message printing.+  , messageWithInfoDiagnosticMessage+  , messageWithHsDocContext+  )+  where++import GHC.Prelude++import qualified Language.Haskell.TH as TH++import GHC.Builtin.Names+import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple )++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 (pprWithExplicitKindsWhen,+                          pprSourceTyCon, pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType)+import GHC.Core.PatSyn ( patSynName, pprPatSynType )+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.FVs( orphNamesOfTypes )+import GHC.CoreToIface++import GHC.Driver.Flags+import GHC.Driver.Backend+import GHC.Hs++import GHC.Tc.Errors.Types+import GHC.Tc.Types.BasicTypes+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Rank (Rank(..))+import GHC.Tc.Types.TH+import GHC.Tc.Utils.TcType++import GHC.Types.Error+import GHC.Types.Hint+import GHC.Types.Hint.Ppr () -- Outputable GhcHint+import GHC.Types.Basic+import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Id+import GHC.Types.Id.Info ( RecSelParent(..) )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.TyThing+import GHC.Types.TyThing.Ppr ( pprTyThingInContext )+import GHC.Types.Unique.Set ( nonDetEltsUniqSet )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Fixity (defaultFixity)++import GHC.Iface.Errors.Types+import GHC.Iface.Errors.Ppr+import GHC.Iface.Syntax++import GHC.Unit.State+import GHC.Unit.Module++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.List.SetOps ( nubOrdBy )+import GHC.Data.Maybe+import GHC.Data.Pair+import GHC.Settings.Constants (mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.BooleanFormula (pprBooleanFormulaNice)++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Foldable ( fold )+import Data.Function (on)+import Data.List ( groupBy, sortBy, tails+                 , partition, unfoldr )+import Data.Ord ( comparing )+import Data.Bifunctor+++defaultTcRnMessageOpts :: TcRnMessageOpts+defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True+                                         , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage }++instance HasDefaultDiagnosticOpts TcRnMessageOpts where+  defaultOpts = defaultTcRnMessageOpts++instance Diagnostic TcRnMessage where+  type DiagnosticOpts TcRnMessage = TcRnMessageOpts+  diagnosticMessage opts = \case+    TcRnUnknownMessage (UnknownDiagnostic f m)+      -> diagnosticMessage (f opts) m+    TcRnMessageWithInfo unit_state msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed err_info msg+             -> messageWithInfoDiagnosticMessage unit_state err_info+                  (tcOptsShowContext opts)+                  (diagnosticMessage opts msg)+    TcRnWithHsDocContext ctxt msg+      -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg)+    TcRnSolverReport msg _ _+      -> mkSimpleDecorated $ pprSolverReportWithCtxt msg+    TcRnSolverDepthError ty depth -> mkSimpleDecorated msg+      where+        msg =+          vcat [ text "Reduction stack overflow; size =" <+> ppr depth+               , hang (text "When simplifying the following type:")+                    2 (ppr ty) ]+    TcRnRedundantConstraints redundants (info, show_info)+      -> mkSimpleDecorated $+         text "Redundant constraint" <> plural redundants <> colon+           <+> pprEvVarTheta redundants+         $$ if show_info then text "In" <+> ppr info else empty+    TcRnInaccessibleCode implic contra+      -> mkSimpleDecorated $+         hang (text "Inaccessible code in")+           2 (ppr (ic_info implic))+         $$ pprSolverReportWithCtxt contra+    TcRnInaccessibleCoAxBranch fam_tc cur_branch+      -> mkSimpleDecorated $+          text "Type family instance equation is overlapped:" $$+          nest 2 (pprCoAxBranchUser fam_tc cur_branch)+    TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary)+      -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary]+    TcRnImplicitLift id_or_name ErrInfo{..}+      -> mkDecorated $+           ( text "The variable" <+> quotes (ppr id_or_name) <+>+             text "is implicitly lifted in the TH quotation"+           ) : [errInfoContext, errInfoSupplementary]+    TcRnUnusedPatternBinds bind+      -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]+    TcRnDodgyImports (DodgyImportsEmptyParent gre)+      -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)]+    TcRnDodgyImports (DodgyImportsHiding reason)+      -> mkSimpleDecorated $+         pprImportLookup reason+    TcRnDodgyExports gre+      -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)]+    TcRnMissingImportList ie+      -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>+                       text "does not have an explicit import list"+                     ]+    TcRnUnsafeDueToPlugin+      -> mkDecorated [text "Use of plugins makes the module unsafe"]+    TcRnModMissingRealSrcSpan mod+      -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod]+    TcRnIdNotExportedFromModuleSig name mod+      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>+                       text "does not exist in the signature for" <+> ppr mod+                     ]+    TcRnIdNotExportedFromLocalSig name+      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>+                       text "does not exist in the local signature."+                     ]+    TcRnShadowedName occ provenance+      -> let shadowed_locs = case provenance of+               ShadowedNameProvenanceLocal n     -> [text "bound at" <+> ppr n]+               ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres+         in mkSimpleDecorated $+            sep [text "This binding for" <+> quotes (ppr occ)+             <+> text "shadows the existing binding" <> plural shadowed_locs,+                   nest 2 (vcat shadowed_locs)]+    TcRnInvalidWarningCategory cat+      -> mkSimpleDecorated $+           vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid",+                 text "(user-defined category names must begin with" <+> quotes (text "x-"),+                 text "and contain only letters, numbers, apostrophes and dashes)" ]+    TcRnDuplicateWarningDecls d rdr_name+      -> mkSimpleDecorated $+           vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),+                 text "also at " <+> ppr (getLocA d)]+    TcRnSimplifierTooManyIterations simples limit wc+      -> mkSimpleDecorated $+           hang (text "solveWanteds: too many iterations"+                   <+> parens (text "limit =" <+> ppr limit))+                2 (vcat [ text "Unsolved:" <+> ppr wc+                        , text "Simples:"  <+> ppr simples+                        ])+    TcRnIllegalPatSynDecl rdrname+      -> mkSimpleDecorated $+           hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))+              2 (text "Pattern synonym declarations are only valid at top level")+    TcRnLinearPatSyn ty+      -> mkSimpleDecorated $+           hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty)+    TcRnEmptyRecordUpdate+      -> mkSimpleDecorated $ text "Empty record update"+    TcRnIllegalFieldPunning fld+      -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)+    TcRnIllegalWildcardsInRecord fld_part+      -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part+    TcRnIllegalWildcardInType mb_name bad+      -> mkSimpleDecorated $ case bad of+          WildcardNotLastInConstraint ->+            hang notAllowed 2 constraint_hint_msg+          ExtraConstraintWildcardNotAllowed allow_sole ->+            case allow_sole of+              SoleExtraConstraintWildcardNotAllowed ->+                notAllowed+              SoleExtraConstraintWildcardAllowed ->+                hang notAllowed 2 sole_msg+          WildcardsNotAllowedAtAll ->+            notAllowed+      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 (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 . 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"+    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 $ 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)+    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 $ 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 gre ie1 ie2+      -> mkSimpleDecorated $+           hsep [ quotes (ppr $ greName gre)+                , text "is exported by", quotes (ppr ie1)+                , text "and",            quotes (ppr ie2) ]+    TcRnExportedParentChildMismatch parent_name ty_thing child parent_names+      -> mkSimpleDecorated $+           text "The type constructor" <+> quotes (ppr parent_name)+                 <+> text "is not the parent of the" <+> text what_is+                 <+> quotes thing <> char '.'+                 $$ text (capitalise what_is)+                    <> text "s can only be exported with their parent type constructor."+                 $$ (case parents of+                       [] -> empty+                       [_] -> text "Parent:"+                       _  -> text "Parents:") <+> fsep (punctuate comma parents)+      where+        pp_category :: TyThing -> String+        pp_category (AnId i)+          | isRecordSelector i = "record selector"+        pp_category i = tyThingCategory i+        what_is = pp_category ty_thing+        thing = ppr $ nameOccName child+        parents = map ppr parent_names+    TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2+      -> mkSimpleDecorated $+           vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon+                , ppr_export child_gre1 ie1+                , ppr_export child_gre2 ie2+                ]+      where+        ppr_export gre ie =+          nest 3 $+            hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre))+               2 (pprNameProvenance gre)+    TcRnDuplicateFieldExport (gre, ie1) gres_ies ->+      mkSimpleDecorated $+           vcat ( hsep [ text "Duplicate record field"+                       , quotes (ppr $ greOccName gre)+                       , text "in export list" <> colon ]+                : map ppr_export ((gre,ie1) : NE.toList gres_ies)+                )+      where+        ppr_export (gre,ie) =+          nest 3 $+            hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre)+                       , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ])+               2 (pprNameProvenance gre)+          where+            fld_cons :: [ConLikeName]+            fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre+    TcRnAmbiguousFieldInUpdate (gre1, gre2, gres)+      -> mkSimpleDecorated $+          vcat [ text "Ambiguous record field" <+> fld <> dot+               , hang (text "It could refer to any of the following:")+                  2 $ vcat (map pprSugg (gre1 : gre2 : gres))+               ]+        where+          fld = quotes $ ppr (occNameFS $ greOccName gre1)+          pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma+                             , nest 2 (pprNameProvenance gre) ]+          pprGRE gre = case greInfo gre of+            IAmRecField {}+              -> let parent = par_is $ greParent gre+                 in text "record field" <+> fld <+> text "of" <+> quotes (ppr parent)+            _ -> text "variable" <+> fld+    TcRnAmbiguousRecordUpdate _rupd tc+      -> mkSimpleDecorated $+          vcat [ text "Ambiguous record update with parent" <+> what <> dot+               , hsep [ text "This type-directed disambiguation mechanism"+                      , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ]+               , text "Consider disambiguating using module qualification instead."+               ]+        where+          what :: SDoc+          what = text "type constructor" <+> quotes (ppr $ RecSelData tc)+    TcRnMissingFields con fields+      -> mkSimpleDecorated $ vcat [header, nest 2 rest]+         where+           rest | null fields = empty+                | otherwise   = vcat (fmap pprField fields)+           header = text "Fields of" <+> quotes (ppr con) <+>+                    text "not initialised" <>+                    if null fields then empty else colon+    TcRnFieldUpdateInvalidType prs+      -> mkSimpleDecorated $+           hang (text "Record update for insufficiently polymorphic field"+                   <> plural prs <> colon)+              2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])+    TcRnMissingStrictFields con fields+      -> mkSimpleDecorated $ vcat [header, nest 2 rest]+         where+           rest | null fields = empty  -- Happens for non-record constructors+                                       -- with strict fields+                | otherwise   = vcat (fmap pprField fields)++           header = text "Constructor" <+> quotes (ppr con) <+>+                    text "does not have the required strict field(s)" <>+                    if null fields then empty else colon+    TcRnBadRecordUpdate upd_flds reason+      -> case reason of+          NoConstructorHasAllFields { conflictingFields = conflicts }+            | [fld] <- conflicts+            -> mkSimpleDecorated $+                vcat [ header+                     , text "No constructor in scope has the field" <+> quotes (ppr fld) ]+            | otherwise+            ->+              mkSimpleDecorated $+                vcat [ header+                     , hang (text "No constructor in scope has all of the following fields:")+                        2 (pprQuotedList conflicts) ]+            where+              header :: SDoc+              header = text "Invalid record update."+          MultiplePossibleParents (par1, par2, pars) ->+            mkSimpleDecorated $+              vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds)+                       2 ppr_flds+                   , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent)+                       2 (quotedListWithAnd (map ppr (par1:par2:pars))) ]+            where+              ppr_flds, what_parent, which :: SDoc+              ppr_flds = quotedListWithAnd $ map ppr upd_flds+              what_parent = case par1 of+                RecSelData   {} -> text "appear" <> singular upd_flds+                                <+> text "in" <+> which <+> text "datatypes"+                RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with"+                                <+> which <+> text "pattern synonyms"+              which = case pars of+                [] -> text "both"+                _  -> text "all of the"+          InvalidTyConParent tc pars ->+            mkSimpleDecorated $+              vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:")+                      2 (pprQuotedList upd_flds)+                   , pat_syn_msg ]+            where+              what = text "type constructor" <+> quotes (ppr (RecSelData tc))+              pat_syn_msg+                | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars+                = text "NB: 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 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+    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"+    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)+    TcRnTermNameInType name _+      -> mkSimpleDecorated $+           quotes (ppr name) <+>+             (text "is a term-level binding") $+$+             (text " and can not be used at the type level.")+    TcRnUntickedPromotedThing thing+      -> mkSimpleDecorated $+         text "Unticked promoted" <+> what+           where+             what :: SDoc+             what = case thing of+               UntickedExplicitList -> text "list" <> dot+               UntickedConstructor fixity nm ->+                 let con      = pprUntickedConstructor fixity nm+                     bare_sym = isBareSymbol fixity nm+                 in text "constructor:" <+> con <> if bare_sym then empty else dot+    TcRnIllegalBuiltinSyntax what rdr_name+      -> mkSimpleDecorated $+           hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name]+    TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty+      -> mkSimpleDecorated $+           hang (hsep $ [ text "Defaulting" ]+                     +++                     (case tidy_tv of+                         Nothing -> []+                         Just tv -> [text "the type variable"+                                    , quotes (ppr tv)])+                     +++                     [ text "to type"+                     , quotes (ppr default_ty)+                     , text "in the following constraint" <> plural tidy_wanteds ])+             2+             (pprWithArising tidy_wanteds)+++    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)+    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 either_ty_ty+      -> mkSimpleDecorated $+           text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty+    TcRnInvalidVisibleKindArgument arg ty+      -> mkSimpleDecorated $+           text "Cannot apply function of kind" <+> quotes (ppr ty)+             $$ text "to visible kind argument" <+> quotes (ppr arg)+    TcRnTooManyBinders ki bndrs+      -> mkSimpleDecorated $+           hang (text "Not a function kind:")+              4 (ppr ki) $$+           hang (text "but extra binders found:")+              4 (fsep (map ppr bndrs))+    TcRnDifferentNamesForTyVar n1 n2+      -> mkSimpleDecorated $+           hang (text "Different names for the same type variable:") 2 info+         where+           info | nameOccName n1 /= nameOccName n2+                = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)+                | otherwise -- Same OccNames! See C2 in+                            -- Note [Swizzling the tyvars before generaliseTcTyCon]+                = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)+                       , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]+    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"+                     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"+                     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"+    TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)+      -> mkSimpleDecorated $+           (vcat [ pprMatchContextNouns argsContext <+>+                   text "have different numbers of arguments"+                 , nest 2 (ppr (getLocA match1))+                 , nest 2 (ppr (getLocA (NE.head bad_matches)))])+    TcRnCannotBindScopedTyVarInPatSig sig_tvs+      -> mkSimpleDecorated $+           hang (text "You cannot bind scoped type variable"+                  <> plural (NE.toList sig_tvs)+                 <+> pprQuotedList (map fst $ NE.toList sig_tvs))+              2 (text "in a pattern binding signature")+    TcRnCannotBindTyVarsInPatBind _offenders+      -> mkSimpleDecorated $+           text "Binding type variables is not allowed in pattern bindings"+    TcRnTooManyTyArgsInConPattern con_like expected_number actual_number+      -> mkSimpleDecorated $+           text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$+           text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number+    TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags+      -> mkSimpleDecorated $+           hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)+             2 (vcat (text "Ignoring all but the first"+                      : map pp_inl (fst_inl_prag : NE.toList inl_prags)))+         where+           pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)+    TcRnUnexpectedPragmas poly_id bad_sigs+      -> mkSimpleDecorated $+           hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)+              2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs))+    TcRnNonOverloadedSpecialisePragma fun_name+       -> mkSimpleDecorated $+            text "SPECIALISE pragma for non-overloaded function"+              <+> quotes (ppr fun_name)+    TcRnSpecialiseNotVisible name+      -> mkSimpleDecorated $+         text "You cannot SPECIALISE" <+> quotes (ppr name)+           <+> text "because its definition is not visible in this module"+    TcRnPragmaWarning {pragma_warning_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 = case pragma_warning_defined_mod of+                      Just def_mod+                        | def_mod /= pragma_warning_import_mod+                          -> text ", but defined in" <+> ppr def_mod+                      _ -> 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 <+> 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+    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))++    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 forward-compatible with a planned GHC extension, RequiredTypeArguments."+        where+          var_names = case shadowed_term_names of+              Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names)+              Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at"+                <+> ppr (nameSrcLoc lcl_name)+    TcRnBindingOfExistingName name -> mkSimpleDecorated $+      text "Illegal binding of an existing name:" <+> ppr (filterCTuple name)+    TcRnMultipleFixityDecls loc rdr_name -> mkSimpleDecorated $+      vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+            text "also at " <+> ppr loc]+    TcRnIllegalPatternSynonymDecl -> mkSimpleDecorated $+      text "Illegal pattern synonym declaration"+    TcRnIllegalClassBinding dsort bind -> mkSimpleDecorated $+      vcat [ what <+> text "not allowed in" <+> decl_sort+              , nest 2 (ppr bind) ]+      where+        decl_sort = case dsort of+          ClassDeclSort -> text "class declaration:"+          InstanceDeclSort -> text "instance declaration:"+        what = case bind of+                  PatBind {}    -> text "Pattern bindings (except simple variables)"+                  PatSynBind {} -> text "Pattern synonyms"+                                   -- Associated pattern synonyms are not implemented yet+                  _ -> pprPanic "rnMethodBind" (ppr bind)+    TcRnOrphanCompletePragma -> mkSimpleDecorated $+      text "Orphan COMPLETE pragmas not supported" $$+      text "A COMPLETE pragma must mention at least one data constructor" $$+      text "or pattern synonym defined in the same module."+    TcRnEmptyCase ctxt -> mkSimpleDecorated message+      where+        pp_ctxt = case ctxt of+          CaseAlt                                  -> text "case expression"+          LamCaseAlt LamCase                       -> text "\\case expression"+          ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"+          ArrowMatchCtxt ArrowCaseAlt              -> text "case command"+          ArrowMatchCtxt KappaExpr                 -> text "kappa abstraction"+          _                                        -> text "(unexpected)"+                                                      <+> pprMatchContextNoun ctxt++        message = case ctxt of+          LamCaseAlt LamCases -> lcases_msg <+> text "expression"+          ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> lcases_msg <+> text "command"+          _ -> text "Empty list of alternatives in" <+> pp_ctxt++        lcases_msg =+          text "Empty list of alternatives is not allowed in \\cases"+    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+    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." ]+    TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $+      text "Illegal standalone deriving declaration"+    TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $+      sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+          text "Forall'd variable" <+> quotes (ppr var) <+>+                  text "does not appear on left hand side"]+    TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $+      text "Illegal standalone kind signature"+    TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $+      sep [text "Rule" <+> pprRuleName name <> colon,+           nest 2 (vcat [err,+                         text "in left-hand side:" <+> ppr lhs])]+      $$+      text "LHS must be of form (f e1 .. en) where f is not forall'd"+      where+        err = case errReason of+          UnboundVariable uv nis -> pprScopeError uv nis+          IllegalExpression -> text "Illegal expression:" <+> ppr bad_e+    TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $+      hang (text "Duplicate role annotations for" <+>+            quotes (ppr $ roleAnnotDeclName first_decl) <> colon)+        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)+      where+        sorted_list = NE.sortBy cmp_loc list+        ((L _ first_decl) :| _) = sorted_list++        pp_role_annot (L loc decl) = hang (ppr decl)+                                        4 (text "-- written at" <+> ppr (locA loc))++        cmp_loc = leftmost_smallest `on` getLocA+    TcRnDuplicateKindSig list -> mkSimpleDecorated $+      hang (text "Duplicate standalone kind signatures for" <+>+            quotes (ppr $ standaloneKindSigName first_decl) <> colon)+        2 (vcat $ map pp_kisig $ NE.toList sorted_list)+      where+        sorted_list = NE.sortBy cmp_loc list+        ((L _ first_decl) :| _) = sorted_list++        pp_kisig (L loc decl) =+          hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc))++        cmp_loc = leftmost_smallest `on` getLocA+    TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $+      text "Illegal deriving strategy" <> colon <+> derivStrategyName ds+    TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $+      text "Illegal use of multiple, consecutive deriving clauses"+    TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text+      "No deriving strategy specified. Did you want stock, newtype, or anyclass?"+    TcRnStupidThetaInGadt{} -> mkSimpleDecorated $+      vcat [text "No context is allowed on a GADT-style data declaration",+            text "(You can put a context on each constructor, though.)"]+    TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $+       hsep [ text "Type variable", quotes (ppr resName) <> comma+            , text "naming a type family result,"+            ] $$+      text "shadows an already bound type variable"+    TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $+        vcat [ text $ "Incorrect type variable on the LHS of "+                   ++ "injectivity condition"+      , nest 5+      ( vcat [ text "Expected :" <+> ppr resName+             , text "Actual   :" <+> ppr injFrom ])]+    TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $+      hsep [ text "Unknown type variable" <> plural errorVars+           , text "on the RHS of injectivity condition:"+           , interpp'SP errorVars ]+    TcRnBadlyStaged reason bind_lvl use_lvl+      -> mkSimpleDecorated $+         text "Stage error:" <+> pprStageCheckReason reason <+>+         hsep [text "is bound at stage" <+> ppr bind_lvl,+               text "but used at stage" <+> ppr use_lvl]+    TcRnStageRestriction reason+      -> mkSimpleDecorated $+         sep [ text "GHC stage restriction:"+             , nest 2 (vcat [ pprStageCheckReason reason <+>+                              text "is used in a top-level splice, quasi-quote, or annotation,"+                            , text "and must be imported, not defined locally"])]+    TcRnTyThingUsedWrong sort thing name+      -> mkSimpleDecorated $+         pprTyThingUsedWrong sort thing name+    TcRnCannotDefaultKindVar var knd ->+      mkSimpleDecorated $+      (vcat [ text "Cannot default kind variable" <+> quotes (ppr var)+            , text "of kind:" <+> ppr knd+            , text "Perhaps enable PolyKinds or add a kind signature" ])+    TcRnUninferrableTyVar tidied_tvs context ->+      mkSimpleDecorated $+      pprWithExplicitKindsWhen True $+      vcat [ text "Uninferrable type variable"+              <> plural tidied_tvs+              <+> pprWithCommas pprTyVar tidied_tvs+              <+> text "in"+            , pprUninferrableTyVarCtx context ]+    TcRnSkolemEscape escapees tv orig_ty ->+      mkSimpleDecorated $+      pprWithExplicitKindsWhen 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 $+      sep [text "Use of partial record field selector" <> colon,+           nest 2 $ quotes (ppr (occName fld))]+    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+          = hang (text "NB: Specified variables")+               2 (sep [pp_spec, text "always come first"])+          | null specified_tvs+          = hang (text "NB: Inferred variables")+               2 (sep [pp_inf, text "always come first"])+          | otherwise+          = hang (text "NB: Inferred variables")+               2 (vcat [ sep [ pp_inf, text "always come first"]+                       , sep [text "then Specified variables", pp_spec]])++        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.")+    TcRnBindVarAlreadyInScope tv_names_in_scope+      -> mkSimpleDecorated $+        vcat+          [ text "Type variable" <> plural tv_names_in_scope+            <+> hcat (punctuate (text ",") (map (quotes . ppr) tv_names_in_scope))+            <+> isOrAre tv_names_in_scope+            <+> text "already in scope."+          , text "Type applications in patterns must bind fresh variables, without shadowing."+          ]++    TcRnBindMultipleVariables ctx tv_name_w_loc+      -> mkSimpleDecorated $+        text "Variable" <+> text "`" <> ppr tv_name_w_loc <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."++    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+      -> mkSimpleDecorated $+           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)+    TcRnCompatUnqualifiedImport decl+      -> mkSimpleDecorated $+         vcat+         [ text "To ensure compatibility with future core libraries changes"+         , text "imports to" <+> ppr (ideclName decl) <+> text "should be"+         , text "either qualified or have an explicit import list."+         ]+    TcRnRedundantSourceImport mod_name+      -> mkSimpleDecorated $+         text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)+    TcRnImportLookup reason+      -> mkSimpleDecorated $+         pprImportLookup reason+    TcRnUnusedImport decl reason+      -> mkSimpleDecorated $+         pprUnusedImport decl reason+    TcRnDuplicateDecls name sorted_names+      -> mkSimpleDecorated $+         vcat [text "Multiple declarations of" <+>+               quotes (ppr name),+                -- NB. print the OccName, not the Name, because the+                -- latter might not be in scope in the RdrEnv and so will+                -- be printed qualified.+               text "Declared at:" <+>+               vcat (NE.toList $ ppr . nameSrcLoc <$> sorted_names)]+    TcRnPackageImportsDisabled+      -> mkSimpleDecorated $+         text "Package-qualified imports are not enabled"+    TcRnIllegalDataCon name+      -> mkSimpleDecorated $+         hsep [text "Illegal data constructor name", quotes (ppr name)]+    TcRnNestedForallsContexts entity+      -> mkSimpleDecorated $+         what <+> text "cannot contain nested"+         <+> quotes forAllLit <> text "s or contexts"+         where+           what = case entity of+             NFC_Specialize -> text "SPECIALISE instance type"+             NFC_ViaType -> quotes (text "via") <+> text "type"+             NFC_GadtConSig -> text "GADT constructor type signature"+             NFC_InstanceHead -> text "Instance head"+             NFC_StandaloneDerivedInstanceHead -> text "Standalone-derived instance head"+             NFC_DerivedClassType -> text "Derived class type"+    TcRnRedundantRecordWildcard+      -> mkSimpleDecorated $+         text "Record wildcard does not bind any new variables"+    TcRnUnusedRecordWildcard _+      -> mkSimpleDecorated $+         text "No variables bound in the record wildcard match are used"+    TcRnUnusedName name reason+      -> mkSimpleDecorated $+         pprUnusedName name reason+    TcRnQualifiedBinder rdr_name+      -> mkSimpleDecorated $+         text "Qualified name in binding position:" <+> ppr rdr_name+    TcRnTypeApplicationsDisabled ty_app+      -> mkSimpleDecorated $+         text "Illegal visible" <+> what <+> text "application" <+> ctx <> colon+           <+> ppr arg+         where+           arg = case ty_app of+            TypeApplication ty _ -> char '@' <> ppr ty+            TypeApplicationInPattern ty_app -> ppr ty_app+           what = case ty_app of+             TypeApplication _ ty_or_ki ->+              case ty_or_ki of+                TypeLevel -> text "type"+                KindLevel -> text "kind"+             TypeApplicationInPattern _ -> text "type"+           ctx = case ty_app of+            TypeApplicationInPattern _ -> text "in a pattern"+            _                          -> empty+    TcRnInvalidRecordField con field+      -> mkSimpleDecorated $+         hsep [text "Constructor" <+> quotes (ppr con),+               text "does not have field", quotes (ppr field)]+    TcRnTupleTooLarge tup_size+      -> mkSimpleDecorated $+         sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",+              nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),+              nest 2 (text "Workaround: use nested tuples or define a data type")]+    TcRnCTupleTooLarge tup_size+      -> mkSimpleDecorated $+         hang (text "Constraint tuple arity too large:" <+> int tup_size+               <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+            2 (text "Instead, use a nested tuple")+    TcRnIllegalInferredTyVars _+      -> mkSimpleDecorated $+         text "Inferred type variables are not allowed"+    TcRnAmbiguousName gre_env name gres+      -> mkSimpleDecorated $+         vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot+              , text "It could refer to"+              , nest 3 (vcat msgs) ]+         where+           np1 NE.:| nps = gres+           msgs = punctuateFinal comma dot $+                    text "either" <+> ppr_gre np1+                 : [text "    or" <+> ppr_gre np | np <- nps]++           ppr_gre gre = pprAmbiguousGreName gre_env gre++    TcRnBindingNameConflict name locs+      -> mkSimpleDecorated $+         vcat [text "Conflicting definitions for" <+> quotes (ppr name),+               locations]+         where+           locations =+             text "Bound at:"+             <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs)))+    TcRnNonCanonicalDefinition reason inst_ty+      -> mkSimpleDecorated $+         pprNonCanonicalDefinition inst_ty reason+    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)++    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+             , text "NB." <+> vcat [+                text "Only" <+> quotes (text "forall a.") <+> text "-quantification matches invisible binders,",+                text "whereas" <+> quotes (text "forall {a}.") <+> text "and" <+> quotes (text "forall a ->") <+> text "do not."+             ]]++    TcRnDeprecatedInvisTyArgInConPat ->+      mkSimpleDecorated $+        cat [ text "Type applications in constructor patterns will require"+            , text "the TypeAbstractions extension starting from GHC 9.12." ]++    TcRnInvisBndrWithoutSig _ hs_bndr ->+      mkSimpleDecorated $+        vcat [ hang (text "Invalid invisible type variable binder:")+                  2 (ppr hs_bndr)+             , text "Either a standalone kind signature (SAKS)"+             , text "or a complete user-supplied kind (CUSK, legacy feature)"+             , text "is required to use invisible binders." ]++    TcRnImplicitRhsQuantification kv -> mkSimpleDecorated $+      vcat [ text "The variable" <+> quotes (ppr kv) <+> text "occurs free on the RHS of the type declaration"+           , text "In the future GHC will no longer implicitly quantify over such variables"+           ]++  diagnosticReason = \case+    TcRnUnknownMessage m+      -> diagnosticReason m+    TcRnMessageWithInfo _ msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed _ m -> diagnosticReason m+    TcRnWithHsDocContext _ msg+      -> diagnosticReason msg+    TcRnSolverReport _ reason _+      -> reason -- Error, or a Warning if we are deferring type errors+    TcRnSolverDepthError {}+      -> ErrorWithoutFlag+    TcRnRedundantConstraints {}+      -> WarningWithFlag Opt_WarnRedundantConstraints+    TcRnInaccessibleCode {}+      -> WarningWithFlag Opt_WarnInaccessibleCode+    TcRnInaccessibleCoAxBranch {}+      -> WarningWithFlag Opt_WarnInaccessibleCode+    TcRnTypeDoesNotHaveFixedRuntimeRep{}+      -> ErrorWithoutFlag+    TcRnImplicitLift{}+      -> WarningWithFlag Opt_WarnImplicitLift+    TcRnUnusedPatternBinds{}+      -> WarningWithFlag Opt_WarnUnusedPatternBinds+    TcRnDodgyImports{}+      -> WarningWithFlag Opt_WarnDodgyImports+    TcRnDodgyExports{}+      -> WarningWithFlag Opt_WarnDodgyExports+    TcRnMissingImportList{}+      -> WarningWithFlag Opt_WarnMissingImportList+    TcRnUnsafeDueToPlugin{}+      -> WarningWithoutFlag+    TcRnModMissingRealSrcSpan{}+      -> ErrorWithoutFlag+    TcRnIdNotExportedFromModuleSig{}+      -> ErrorWithoutFlag+    TcRnIdNotExportedFromLocalSig{}+      -> ErrorWithoutFlag+    TcRnShadowedName{}+      -> WarningWithFlag Opt_WarnNameShadowing+    TcRnInvalidWarningCategory{}+      -> ErrorWithoutFlag+    TcRnDuplicateWarningDecls{}+      -> ErrorWithoutFlag+    TcRnSimplifierTooManyIterations{}+      -> ErrorWithoutFlag+    TcRnIllegalPatSynDecl{}+      -> ErrorWithoutFlag+    TcRnLinearPatSyn{}+      -> ErrorWithoutFlag+    TcRnEmptyRecordUpdate+      -> ErrorWithoutFlag+    TcRnIllegalFieldPunning{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardsInRecord{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardInType{}+      -> ErrorWithoutFlag+    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+    TcRnDuplicateExport{}+      -> WarningWithFlag Opt_WarnDuplicateExports+    TcRnExportedParentChildMismatch{}+      -> ErrorWithoutFlag+    TcRnConflictingExports{}+      -> ErrorWithoutFlag+    TcRnDuplicateFieldExport {}+      -> ErrorWithoutFlag+    TcRnAmbiguousFieldInUpdate {}+      -> ErrorWithoutFlag+    TcRnAmbiguousRecordUpdate{}+      -> WarningWithFlag Opt_WarnAmbiguousFields+    TcRnMissingFields{}+      -> WarningWithFlag Opt_WarnMissingFields+    TcRnFieldUpdateInvalidType{}+      -> ErrorWithoutFlag+    TcRnMissingStrictFields{}+      -> ErrorWithoutFlag+    TcRnBadRecordUpdate{}+      -> ErrorWithoutFlag+    TcRnIllegalStaticExpression {}+      -> ErrorWithoutFlag+    TcRnStaticFormNotClosed{}+      -> ErrorWithoutFlag+    TcRnUselessTypeable+      -> WarningWithFlag Opt_WarnDerivingTypeable+    TcRnDerivingDefaults{}+      -> WarningWithFlag Opt_WarnDerivingDefaults+    TcRnNonUnaryTypeclassConstraint{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSignatures{}+      -> WarningWithFlag Opt_WarnPartialTypeSignatures+    TcRnCannotDeriveInstance _ _ _ _ rea+      -> case rea of+           DerivErrNotWellKinded{}                 -> ErrorWithoutFlag+           DerivErrSafeHaskellGenericInst          -> ErrorWithoutFlag+           DerivErrDerivingViaWrongKind{}          -> ErrorWithoutFlag+           DerivErrNoEtaReduce{}                   -> ErrorWithoutFlag+           DerivErrBootFileFound                   -> ErrorWithoutFlag+           DerivErrDataConsNotAllInScope{}         -> ErrorWithoutFlag+           DerivErrGNDUsedOnData                   -> ErrorWithoutFlag+           DerivErrNullaryClasses                  -> ErrorWithoutFlag+           DerivErrLastArgMustBeApp                -> ErrorWithoutFlag+           DerivErrNoFamilyInstance{}              -> ErrorWithoutFlag+           DerivErrNotStockDeriveable{}            -> ErrorWithoutFlag+           DerivErrHasAssociatedDatatypes{}        -> ErrorWithoutFlag+           DerivErrNewtypeNonDeriveableClass       -> ErrorWithoutFlag+           DerivErrCannotEtaReduceEnough{}         -> ErrorWithoutFlag+           DerivErrOnlyAnyClassDeriveable{}        -> ErrorWithoutFlag+           DerivErrNotDeriveable{}                 -> ErrorWithoutFlag+           DerivErrNotAClass{}                     -> ErrorWithoutFlag+           DerivErrNoConstructors{}                -> ErrorWithoutFlag+           DerivErrLangExtRequired{}               -> ErrorWithoutFlag+           DerivErrDunnoHowToDeriveForType{}       -> ErrorWithoutFlag+           DerivErrMustBeEnumType{}                -> ErrorWithoutFlag+           DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag+           DerivErrMustHaveSomeParameters{}        -> ErrorWithoutFlag+           DerivErrMustNotHaveClassContext{}       -> ErrorWithoutFlag+           DerivErrBadConstructor{}                -> ErrorWithoutFlag+           DerivErrGenerics{}                      -> ErrorWithoutFlag+           DerivErrEnumOrProduct{}                 -> ErrorWithoutFlag+    TcRnLookupInstance _ _ _+      -> ErrorWithoutFlag+    TcRnLazyGADTPattern+      -> ErrorWithoutFlag+    TcRnArrowProcGADTPattern+      -> ErrorWithoutFlag+    TcRnForallIdentifier {}+      -> WarningWithFlag Opt_WarnForallIdentifier+    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+    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+    TcRnUnexpectedAnnotation{}+      -> ErrorWithoutFlag+    TcRnIllegalRecordSyntax{}+      -> ErrorWithoutFlag+    TcRnInvalidVisibleKindArgument{}+      -> ErrorWithoutFlag+    TcRnTooManyBinders{}+      -> ErrorWithoutFlag+    TcRnDifferentNamesForTyVar{}+      -> ErrorWithoutFlag+    TcRnInvalidReturnKind{}+      -> ErrorWithoutFlag+    TcRnClassKindNotConstraint{}+      -> ErrorWithoutFlag+    TcRnUnpromotableThing{}+      -> ErrorWithoutFlag+    TcRnMatchesHaveDiffNumArgs{}+      -> ErrorWithoutFlag+    TcRnCannotBindScopedTyVarInPatSig{}+      -> ErrorWithoutFlag+    TcRnCannotBindTyVarsInPatBind{}+      -> ErrorWithoutFlag+    TcRnTooManyTyArgsInConPattern{}+      -> ErrorWithoutFlag+    TcRnMultipleInlinePragmas{}+      -> WarningWithoutFlag+    TcRnUnexpectedPragmas{}+      -> WarningWithoutFlag+    TcRnNonOverloadedSpecialisePragma{}+      -> WarningWithoutFlag+    TcRnSpecialiseNotVisible{}+      -> WarningWithoutFlag+    TcRnPragmaWarning{pragma_warning_msg}+      -> WarningWithCategory (warningTxtCategory pragma_warning_msg)+    TcRnDifferentExportWarnings _ _+      -> ErrorWithoutFlag+    TcRnIncompleteExportWarnings _ _+      -> WarningWithFlag Opt_WarnIncompleteExportWarnings+    TcRnIllegalHsigDefaultMethods{}+      -> ErrorWithoutFlag+    TcRnHsigFixityMismatch{}+      -> ErrorWithoutFlag+    TcRnHsigShapeMismatch{}+      -> ErrorWithoutFlag+    TcRnHsigMissingModuleExport{}+      -> ErrorWithoutFlag+    TcRnBadGenericMethod{}+      -> ErrorWithoutFlag+    TcRnWarningMinimalDefIncomplete{}+      -> WarningWithoutFlag+    TcRnDefaultMethodForPragmaLacksBinding{}+      -> ErrorWithoutFlag+    TcRnIgnoreSpecialisePragmaOnDefMethod{}+      -> WarningWithoutFlag+    TcRnBadMethodErr{}+      -> ErrorWithoutFlag+    TcRnIllegalTypeData+      -> ErrorWithoutFlag+    TcRnIllegalQuasiQuotes{}+      -> ErrorWithoutFlag+    TcRnTHError err+      -> thErrorReason err+    TcRnTypeDataForbids{}+      -> ErrorWithoutFlag+    TcRnIllegalNewtype{}+      -> ErrorWithoutFlag+    TcRnUnsatisfiedMinimalDef{}+      -> WarningWithFlag (Opt_WarnMissingMethods)+    TcRnMisplacedInstSig{}+      -> ErrorWithoutFlag+    TcRnNoRebindableSyntaxRecordDot{}+      -> ErrorWithoutFlag+    TcRnNoFieldPunsRecordDot{}+      -> ErrorWithoutFlag+    TcRnListComprehensionDuplicateBinding{}+      -> ErrorWithoutFlag+    TcRnEmptyStmtsGroup{}+      -> ErrorWithoutFlag+    TcRnLastStmtNotExpr{}+      -> ErrorWithoutFlag+    TcRnUnexpectedStatementInContext{}+      -> ErrorWithoutFlag+    TcRnSectionWithoutParentheses{}+      -> ErrorWithoutFlag+    TcRnIllegalImplicitParameterBindings{}+      -> ErrorWithoutFlag+    TcRnIllegalTupleSection{}+      -> ErrorWithoutFlag+    TcRnCapturedTermName{}+      -> WarningWithFlag Opt_WarnTermVariableCapture+    TcRnBindingOfExistingName{}+      -> ErrorWithoutFlag+    TcRnMultipleFixityDecls{}+      -> ErrorWithoutFlag+    TcRnIllegalPatternSynonymDecl{}+      -> ErrorWithoutFlag+    TcRnIllegalClassBinding{}+      -> ErrorWithoutFlag+    TcRnOrphanCompletePragma{}+      -> ErrorWithoutFlag+    TcRnEmptyCase{}+      -> ErrorWithoutFlag+    TcRnNonStdGuards{}+      -> WarningWithoutFlag+    TcRnDuplicateSigDecl{}+      -> ErrorWithoutFlag+    TcRnMisplacedSigDecl{}+      -> ErrorWithoutFlag+    TcRnUnexpectedDefaultSig{}+      -> ErrorWithoutFlag+    TcRnDuplicateMinimalSig{}+      -> ErrorWithoutFlag+    TcRnLoopySuperclassSolve{}+      -> WarningWithFlag Opt_WarnLoopySuperclassSolve+    TcRnUnexpectedStandaloneDerivingDecl{}+      -> ErrorWithoutFlag+    TcRnUnusedVariableInRuleDecl{}+      -> ErrorWithoutFlag+    TcRnUnexpectedStandaloneKindSig{}+      -> ErrorWithoutFlag+    TcRnIllegalRuleLhs{}+      -> ErrorWithoutFlag+    TcRnDuplicateRoleAnnot{}+      -> ErrorWithoutFlag+    TcRnDuplicateKindSig{}+      -> ErrorWithoutFlag+    TcRnIllegalDerivStrategy{}+      -> ErrorWithoutFlag+    TcRnIllegalMultipleDerivClauses{}+      -> ErrorWithoutFlag+    TcRnNoDerivStratSpecified{}+      -> WarningWithFlag Opt_WarnMissingDerivingStrategies+    TcRnStupidThetaInGadt{}+      -> ErrorWithoutFlag+    TcRnShadowedTyVarNameInFamResult{}+      -> ErrorWithoutFlag+    TcRnIncorrectTyVarOnLhsOfInjCond{}+      -> ErrorWithoutFlag+    TcRnUnknownTyVarsOnRhsOfInjCond{}+      -> ErrorWithoutFlag+    TcRnBadlyStaged{}+      -> ErrorWithoutFlag+    TcRnStageRestriction{}+      -> ErrorWithoutFlag+    TcRnTyThingUsedWrong{}+      -> ErrorWithoutFlag+    TcRnCannotDefaultKindVar{}+      -> ErrorWithoutFlag+    TcRnUninferrableTyVar{}+      -> ErrorWithoutFlag+    TcRnSkolemEscape{}+      -> ErrorWithoutFlag+    TcRnPatSynEscapedCoercion{}+      -> ErrorWithoutFlag+    TcRnPatSynExistentialInResult{}+      -> ErrorWithoutFlag+    TcRnPatSynArityMismatch{}+      -> ErrorWithoutFlag+    TcRnPatSynInvalidRhs{}+      -> ErrorWithoutFlag+    TcRnTyFamDepsDisabled{}+      -> ErrorWithoutFlag+    TcRnAbstractClosedTyFamDecl{}+      -> ErrorWithoutFlag+    TcRnPartialFieldSelector{}+      -> WarningWithFlag Opt_WarnPartialFields+    TcRnBadFieldAnnotation _ _ LazyFieldsDisabled+      -> ErrorWithoutFlag+    TcRnBadFieldAnnotation{}+      -> WarningWithoutFlag+    TcRnSuperclassCycle{}+      -> ErrorWithoutFlag+    TcRnDefaultSigMismatch{}+      -> ErrorWithoutFlag+    TcRnTyFamsDisabled{}+      -> ErrorWithoutFlag+    TcRnBadTyConTelescope {}+      -> ErrorWithoutFlag+    TcRnTyFamResultDisabled{}+      -> ErrorWithoutFlag+    TcRnRoleValidationFailed{}+      -> ErrorWithoutFlag+    TcRnCommonFieldResultTypeMismatch{}+      -> ErrorWithoutFlag+    TcRnCommonFieldTypeMismatch{}+      -> ErrorWithoutFlag+    TcRnClassExtensionDisabled{}+      -> ErrorWithoutFlag+    TcRnDataConParentTypeMismatch{}+      -> ErrorWithoutFlag+    TcRnGADTsDisabled{}+      -> ErrorWithoutFlag+    TcRnExistentialQuantificationDisabled{}+      -> ErrorWithoutFlag+    TcRnGADTDataContext{}+      -> ErrorWithoutFlag+    TcRnMultipleConForNewtype{}+      -> ErrorWithoutFlag+    TcRnKindSignaturesDisabled{}+      -> ErrorWithoutFlag+    TcRnEmptyDataDeclsDisabled{}+      -> ErrorWithoutFlag+    TcRnRoleMismatch{}+      -> ErrorWithoutFlag+    TcRnRoleCountMismatch{}+      -> ErrorWithoutFlag+    TcRnIllegalRoleAnnotation{}+      -> ErrorWithoutFlag+    TcRnRoleAnnotationsDisabled{}+      -> ErrorWithoutFlag+    TcRnIncoherentRoles{}+      -> ErrorWithoutFlag+    TcRnBindVarAlreadyInScope{}+      -> ErrorWithoutFlag+    TcRnBindMultipleVariables{}+      -> 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)+    TcRnCompatUnqualifiedImport{}+      -> WarningWithFlag Opt_WarnCompatUnqualifiedImports+    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+    TcRnImplicitImportOfPrelude {}+      -> WarningWithFlag Opt_WarnImplicitPrelude+    TcRnMissingMain {}+      -> ErrorWithoutFlag+    TcRnGhciUnliftedBind {}+      -> ErrorWithoutFlag+    TcRnGhciMonadLookupFail {}+      -> ErrorWithoutFlag+    TcRnMissingRoleAnnotation{}+      -> WarningWithFlag Opt_WarnMissingRoleAnnotations+    TcRnIllegalInvisTyVarBndr{}+      -> ErrorWithoutFlag+    TcRnDeprecatedInvisTyArgInConPat {}+      -> WarningWithoutFlag+    TcRnInvalidInvisTyVarBndr{}+      -> ErrorWithoutFlag+    TcRnInvisBndrWithoutSig{}+      -> ErrorWithoutFlag+    TcRnImplicitRhsQuantification{}+      -> WarningWithFlag Opt_WarnImplicitRhsQuantification+    TcRnPatersonCondFailure{}+      -> 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+    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+    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{}+      -> noHints+    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+    TcRnDuplicateExport{}+      -> noHints+    TcRnExportedParentChildMismatch{}+      -> noHints+    TcRnConflictingExports{}+      -> noHints+    TcRnDuplicateFieldExport {}+      -> [suggestExtension LangExt.DuplicateRecordFields]+    TcRnAmbiguousFieldInUpdate {}+      -> [suggestExtension LangExt.DisambiguateRecordFields]+    TcRnAmbiguousRecordUpdate{}+      -> noHints+    TcRnMissingFields{}+      -> noHints+    TcRnFieldUpdateInvalidType{}+      -> noHints+    TcRnMissingStrictFields{}+      -> noHints+    TcRnBadRecordUpdate{}+      -> noHints+    TcRnIllegalStaticExpression {}+      -> [suggestExtension LangExt.StaticPointers]+    TcRnStaticFormNotClosed{}+      -> noHints+    TcRnUselessTypeable+      -> noHints+    TcRnDerivingDefaults{}+      -> [useDerivingStrategies]+    TcRnNonUnaryTypeclassConstraint{}+      -> noHints+    TcRnPartialTypeSignatures suggestParSig _+      -> case suggestParSig of+           YesSuggestPartialTypeSignatures+             -> let info = text "to use the inferred type"+                in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures]+           NoSuggestPartialTypeSignatures+             -> noHints+    TcRnCannotDeriveInstance cls _ _ newtype_deriving rea+      -> deriveInstanceErrReasonHints cls newtype_deriving rea+    TcRnLookupInstance _ _ _+      -> noHints+    TcRnLazyGADTPattern+      -> noHints+    TcRnArrowProcGADTPattern+      -> noHints+    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+    TcRnTermNameInType _ hints+      -> 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 tc _ <- why+             -> let tc_nm = tyConName tc+                    dc = dataConName $ head $ tyConDataCons tc+                in [ ImportSuggestion (occName dc)+                   $ ImportDataCon Nothing (nameOccName tc_nm) ]+             | UnliftedFFITypesNeeded <- why+             -> [suggestExtension LangExt.UnliftedFFITypes]+           _ -> noHints+    TcRnInvalidCIdentifier{}+      -> noHints+    TcRnExpectedValueId{}+      -> noHints+    TcRnRecSelectorEscapedTyVar{}+      -> [SuggestPatternMatchingSyntax]+    TcRnPatSynNotBidirectional{}+      -> noHints+    TcRnIllegalDerivingItem{}+      -> noHints+    TcRnUnexpectedAnnotation{}+      -> noHints+    TcRnIllegalRecordSyntax{}+      -> noHints+    TcRnInvalidVisibleKindArgument{}+      -> noHints+    TcRnTooManyBinders{}+      -> noHints+    TcRnDifferentNamesForTyVar{}+      -> noHints+    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]+    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+    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 ctxt -> case ctxt of+      LamCaseAlt LamCases -> noHints -- cases syntax doesn't support empty case.+      ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> noHints+      _ -> [suggestExtension LangExt.EmptyCase]+    TcRnNonStdGuards{}+      -> [suggestExtension LangExt.PatternGuards]+    TcRnDuplicateSigDecl{}+      -> noHints+    TcRnMisplacedSigDecl{}+      -> noHints+    TcRnUnexpectedDefaultSig{}+      -> [suggestExtension LangExt.DefaultSignatures]+    TcRnDuplicateMinimalSig{}+      -> noHints+    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+    TcRnUnexpectedStandaloneDerivingDecl{}+      -> [suggestExtension LangExt.StandaloneDeriving]+    TcRnUnusedVariableInRuleDecl{}+      -> noHints+    TcRnUnexpectedStandaloneKindSig{}+      -> [suggestExtension LangExt.StandaloneKindSignatures]+    TcRnIllegalRuleLhs{}+      -> noHints+    TcRnDuplicateRoleAnnot{}+      -> noHints+    TcRnDuplicateKindSig{}+      -> noHints+    TcRnIllegalDerivStrategy ds -> case ds of+      ViaStrategy{} -> [suggestExtension LangExt.DerivingVia]+      _ -> [suggestExtension LangExt.DerivingStrategies]+    TcRnIllegalMultipleDerivClauses{}+      -> [suggestExtension LangExt.DerivingStrategies]+    TcRnNoDerivStratSpecified isDSEnabled -> if isDSEnabled+      then noHints+      else [suggestExtension LangExt.DerivingStrategies]+    TcRnStupidThetaInGadt{}+      -> noHints+    TcRnShadowedTyVarNameInFamResult{}+      -> noHints+    TcRnIncorrectTyVarOnLhsOfInjCond{}+      -> noHints+    TcRnUnknownTyVarsOnRhsOfInjCond{}+      -> noHints+    TcRnBadlyStaged{}+      -> noHints+    TcRnStageRestriction{}+      -> noHints+    TcRnTyThingUsedWrong{}+      -> noHints+    TcRnCannotDefaultKindVar{}+      -> noHints+    TcRnUninferrableTyVar{}+      -> noHints+    TcRnSkolemEscape{}+      -> noHints+    TcRnPatSynEscapedCoercion{}+      -> noHints+    TcRnPatSynExistentialInResult{}+      -> noHints+    TcRnPatSynArityMismatch{}+      -> noHints+    TcRnPatSynInvalidRhs name pat args (PatSynNotInvertible _)+      -> [SuggestExplicitBidiPatSyn name pat args]+    TcRnPatSynInvalidRhs{}+      -> noHints+    TcRnTyFamDepsDisabled{}+      -> [suggestExtension LangExt.TypeFamilyDependencies]+    TcRnAbstractClosedTyFamDecl{}+      -> noHints+    TcRnPartialFieldSelector{}+      -> noHints+    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{}+      -> [suggestExtension LangExt.ExistentialQuantification,+          suggestExtension 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]+    TcRnBindVarAlreadyInScope{}+      -> noHints+    TcRnBindMultipleVariables{}+      -> noHints+    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+    TcRnCompatUnqualifiedImport{}+      -> noHints+    TcRnRedundantSourceImport{}+      -> noHints+    TcRnImportLookup (ImportLookupBad k _ is ie patsyns_enabled) ->+      let mod_name = moduleName $ is_mod is+          occ = rdrNameOcc $ ieName ie+      in case k of+        BadImportAvailVar         -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]+        BadImportNotExported suggs -> suggs+        BadImportAvailTyCon       -> [ImportSuggestion occ $ CouldAddTypeKeyword mod_name]+        BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]+        BadImportNotExportedSubordinates{} -> noHints+    TcRnImportLookup{}+      -> noHints+    TcRnUnusedImport{}+      -> noHints+    TcRnDuplicateDecls{}+      -> noHints+    TcRnPackageImportsDisabled+      -> [suggestExtension LangExt.PackageImports]+    TcRnIllegalDataCon{}+      -> noHints+    TcRnNestedForallsContexts{}+      -> noHints+    TcRnRedundantRecordWildcard+      -> [SuggestRemoveRecordWildcard]+    TcRnUnusedRecordWildcard{}+      -> [SuggestRemoveRecordWildcard]+    TcRnUnusedName{}+      -> noHints+    TcRnQualifiedBinder{}+      -> noHints+    TcRnTypeApplicationsDisabled ty_app+      -> case ty_app of+          TypeApplication {}+            -> [suggestExtension LangExt.TypeApplications]+          TypeApplicationInPattern {}+            -> [suggestExtension LangExt.TypeAbstractions]+    TcRnInvalidRecordField{}+      -> noHints+    TcRnTupleTooLarge{}+      -> noHints+    TcRnCTupleTooLarge{}+      -> noHints+    TcRnIllegalInferredTyVars{}+      -> noHints+    TcRnAmbiguousName{}+      -> noHints+    TcRnBindingNameConflict{}+      -> noHints+    TcRnNonCanonicalDefinition reason _+      -> suggestNonCanonicalDefinition reason+    TcRnImplicitImportOfPrelude {}+      -> noHints+    TcRnMissingMain {}+      -> noHints+    TcRnGhciUnliftedBind {}+      -> noHints+    TcRnGhciMonadLookupFail {}+      -> noHints+    TcRnMissingRoleAnnotation{}+      -> noHints+    TcRnIllegalInvisTyVarBndr{}+      -> [suggestExtension LangExt.TypeAbstractions]+    TcRnDeprecatedInvisTyArgInConPat{}+      -> [suggestExtension LangExt.TypeAbstractions]+    TcRnInvalidInvisTyVarBndr{}+      -> noHints+    TcRnInvisBndrWithoutSig name _+      -> [SuggestAddStandaloneKindSignature name]+    TcRnImplicitRhsQuantification kv+      -> [SuggestBindTyVarOnLhs (unLoc kv)]+    TcRnPatersonCondFailure{}+      -> [suggestExtension LangExt.UndecidableInstances]++  diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode+  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'++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+  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) = 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+  RecordFieldDecl {}       -> text "declaration"+  RecordFieldConstructor{} -> text "construction"+  RecordFieldPattern{}     -> text "pattern"+  RecordFieldUpdate        -> text "update"++ppr_opfix :: (OpName, Fixity) -> SDoc+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)+   where+     pp_op | NegateOp <- op = text "prefix `-'"+           | otherwise      = quotes (ppr op)++pprBindings :: [Name] -> SDoc+pprBindings = pprWithCommas (quotes . ppr)+++injectivityErrorHerald :: SDoc+injectivityErrorHerald =+  text "Type family equation violates the family's injectivity annotation."++formatExportItemError :: SDoc -> String -> SDoc+formatExportItemError exportedThing reason =+  hsep [ text "The export item"+       , quotes exportedThing+       , text reason ]++-- | What warning flags are associated with the given missing signature?+missingSignatureWarningFlags :: MissingSignature -> Exported -> NonEmpty WarningFlag+missingSignatureWarningFlags (MissingTopLevelBindingSig {}) exported+  -- We prefer "bigger" warnings first: #14794+  --+  -- See Note [Warnings controlled by multiple flags]+  = Opt_WarnMissingSignatures :|+    [ Opt_WarnMissingExportedSignatures | IsExported == exported ]+missingSignatureWarningFlags (MissingPatSynSig {}) exported+  = Opt_WarnMissingPatternSynonymSignatures :|+    [ Opt_WarnMissingExportedPatternSynonymSignatures | IsExported  == exported ]+missingSignatureWarningFlags (MissingTyConKindSig ty_con _) _+  = Opt_WarnMissingKindSignatures :| [Opt_WarnMissingPolyKindSignatures | isForAllTy_invis_ty (tyConKind ty_con) ]++useDerivingStrategies :: GhcHint+useDerivingStrategies =+  useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies++useGND :: GhcHint+useGND = let info = text "for GHC's" <+> text "newtype-deriving extension"+         in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving++cannotMakeDerivedInstanceHerald :: Class+                                -> [Type]+                                -> Maybe (DerivStrategy GhcTc)+                                -> UsingGeneralizedNewtypeDeriving+                                -> Bool -- ^ If False, only prints the why.+                                -> SDoc+                                -> SDoc+cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why =+  if pprHerald+     then sep [(hang (text "Can't make a derived instance of")+                   2 (quotes (ppr pred) <+> via_mechanism)+                $$ nest 2 extra) <> colon,+               nest 2 why]+      else why+  where+    strat_used = isJust mb_strat+    extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving)+          = text "(even with cunning GeneralizedNewtypeDeriving)"+          | otherwise = empty+    pred = mkClassPred cls cls_args+    via_mechanism | strat_used+                  , Just strat <- mb_strat+                  = text "with the" <+> (derivStrategyName strat) <+> text "strategy"+                  | otherwise+                  = empty++badCon :: DataCon -> SDoc -> SDoc+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg++derivErrDiagnosticMessage :: Class+                          -> [Type]+                          -> Maybe (DerivStrategy GhcTc)+                          -> UsingGeneralizedNewtypeDeriving+                          -> Bool -- If True, includes the herald \"can't make a derived..\"+                          -> DeriveInstanceErrReason+                          -> SDoc+derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case+  DerivErrNotWellKinded tc cls_kind _+    -> sep [ hang (text "Cannot derive well-kinded instance of form"+                         <+> quotes (pprClassPred cls cls_tys+                                       <+> parens (ppr tc <+> text "...")))+                  2 empty+           , nest 2 (text "Class" <+> quotes (ppr cls)+                         <+> text "expects an argument of kind"+                         <+> quotes (pprKind cls_kind))+           ]+  DerivErrSafeHaskellGenericInst+    ->     text "Generic instances can only be derived in"+       <+> text "Safe Haskell using the stock strategy."+  DerivErrDerivingViaWrongKind cls_kind via_ty via_kind+    -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))+          2 (text "Class" <+> quotes (ppr cls)+                  <+> text "expects an argument of kind"+                  <+> quotes (pprKind cls_kind) <> char ','+         $+$ text "but" <+> quotes (pprType via_ty)+                  <+> text "has kind" <+> quotes (pprKind via_kind))+  DerivErrNoEtaReduce inst_ty+    -> sep [text "Cannot eta-reduce to an instance of form",+            nest 2 (text "instance (...) =>"+                   <+> pprClassPred cls (cls_tys ++ [inst_ty]))]+  DerivErrBootFileFound+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Cannot derive instances in hs-boot files"+          $+$ text "Write an instance declaration instead")+  DerivErrDataConsNotAllInScope tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope")+            2 (text "so you cannot derive an instance for it"))+  DerivErrGNDUsedOnData+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes")+  DerivErrNullaryClasses+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Cannot derive instances for nullary classes")+  DerivErrLastArgMustBeApp+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         ( text "The last argument of the instance must be a"+         <+> text "data or newtype application")+  DerivErrNoFamilyInstance tc tc_args+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "No family instance for" <+> quotes (pprTypeApp tc tc_args))+  DerivErrNotStockDeriveable _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)")+  DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg+               , case at_without_last_cls_tv of+                    YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc+                    NoAssociatedTyNotParamOverLastTyVar     -> empty+               , case at_last_cls_tv_in_kinds of+                   YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc+                   NoAssocTyLastVarInKind     -> empty+               ]+       where++         adfs_msg  = text "the class has associated data types"++         at_without_last_cls_tv_msg at_tc = hang+           (text "the associated type" <+> quotes (ppr at_tc)+            <+> text "is not parameterized over the last type variable")+           2 (text "of the class" <+> quotes (ppr cls))++         at_last_cls_tv_in_kinds_msg at_tc = hang+           (text "the associated type" <+> quotes (ppr at_tc)+            <+> text "contains the last type variable")+          2 (text "of the class" <+> quotes (ppr cls)+            <+> text "in a kind, which is not (yet) allowed")+  DerivErrNewtypeNonDeriveableClass+    -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled)+  DerivErrCannotEtaReduceEnough eta_ok+    -> let cant_derive_err = ppUnless eta_ok eta_msg+           eta_msg = text "cannot eta-reduce the representation type enough"+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+          cant_derive_err+  DerivErrOnlyAnyClassDeriveable tc _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr tc) <+> text "is a type class,"+                          <+> text "and can only have a derived instance"+                          $+$ text "if DeriveAnyClass is enabled")+  DerivErrNotDeriveable _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty+  DerivErrNotAClass predType+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr predType) <+> text "is not a class")+  DerivErrNoConstructors rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor")+  DerivErrLangExtRequired ext+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "You need " <> ppr ext+            <+> text "to derive an instance for this class")+  DerivErrDunnoHowToDeriveForType ty+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+        (hang (text "Don't know how to derive" <+> quotes (ppr cls))+              2 (text "for type" <+> quotes (ppr ty)))+  DerivErrMustBeEnumType rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (sep [ quotes (pprSourceTyCon rep_tc) <+>+                text "must be an enumeration type"+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ])++  DerivErrMustHaveExactlyOneConstructor rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor")+  DerivErrMustHaveSomeParameters rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters")+  DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Data type" <+> quotes (ppr rep_tc)+           <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)+  DerivErrBadConstructor _ reasons+    -> let why = vcat $ map renderReason reasons+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+         where+           renderReason = \case+                 DerivErrBadConExistential con+                   -> badCon con $ text "must be truly polymorphic in the last argument of the data type"+                 DerivErrBadConCovariant con+                   -> badCon con $ text "must not use the type variable in a function argument"+                 DerivErrBadConFunTypes con+                   -> badCon con $ text "must not contain function types"+                 DerivErrBadConWrongArg con+                   -> badCon con $ text "must use the type variable only as the last argument of a data type"+                 DerivErrBadConIsGADT con+                   -> badCon con $ text "is a GADT"+                 DerivErrBadConHasExistentials con+                   -> badCon con $ text "has existential type variables in its type"+                 DerivErrBadConHasConstraints con+                   -> badCon con $ text "has constraints in its type"+                 DerivErrBadConHasHigherRankType con+                   -> badCon con $ text "has a higher-rank type"+  DerivErrGenerics reasons+    -> let why = vcat $ map renderReason reasons+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+         where+           renderReason = \case+             DerivErrGenericsMustNotHaveDatatypeContext tc_name+                -> ppr tc_name <+> text "must not have a datatype context"+             DerivErrGenericsMustNotHaveExoticArgs dc+                -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments"+             DerivErrGenericsMustBeVanillaDataCon dc+                -> ppr dc <+> text "must be a vanilla data constructor"+             DerivErrGenericsMustHaveSomeTypeParams rep_tc+                ->     text "Data type" <+> quotes (ppr rep_tc)+                   <+> text "must have some type parameters"+             DerivErrGenericsMustNotHaveExistentials con+               -> badCon con $ text "must not have existential arguments"+             DerivErrGenericsWrongArgKind con+               -> badCon con $+                    text "applies a type to an argument involving the last parameter"+                 $$ text "but the applied type is not of kind * -> *"+  DerivErrEnumOrProduct this that+    -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this+           ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+          (ppr1 $$ text "  or" $$ ppr2)++lookupInstanceErrDiagnosticMessage :: Class+                                   -> [Type]+                                   -> LookupInstanceErrReason+                                   -> SDoc+lookupInstanceErrDiagnosticMessage cls tys = \case+  LookupInstErrNotExact+    -> text "Not an exact match (i.e., some variables get instantiated)"+  LookupInstErrFlexiVar+    -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys)+  LookupInstErrNotFound+    -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys)++{- *********************************************************************+*                                                                      *+              Outputable SolverReportErrCtxt (for debugging)+*                                                                      *+**********************************************************************-}++instance Outputable SolverReportErrCtxt where+  ppr (CEC { cec_binds              = bvar+           , cec_defer_type_errors  = dte+           , cec_expr_holes         = eh+           , cec_type_holes         = th+           , cec_out_of_scope_holes = osh+           , cec_warn_redundant     = wr+           , cec_expand_syns        = es+           , cec_suppress           = sup })+    = text "CEC" <+> braces (vcat+         [ text "cec_binds"              <+> equals <+> ppr bvar+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte+         , text "cec_expr_holes"         <+> equals <+> ppr eh+         , text "cec_type_holes"         <+> equals <+> ppr th+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh+         , text "cec_warn_redundant"     <+> equals <+> ppr wr+         , text "cec_expand_syns"        <+> equals <+> ppr es+         , text "cec_suppress"           <+> equals <+> ppr sup ])++{- *********************************************************************+*                                                                      *+                    Outputting TcSolverReportMsg errors+*                                                                      *+**********************************************************************-}++-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg'+-- with its enclosing 'SolverReportErrCtxt'.+pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc+pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg })+   = pprTcSolverReportMsg ctxt msg++-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'.+pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc+pprTcSolverReportMsg _ (BadTelescope telescope skols) =+  hang (text "These kind and type variables:" <+> ppr telescope $$+       text "are out of dependency order. Perhaps try this ordering:")+    2 (pprTyVars sorted_tvs)+  where+    sorted_tvs = scopedSort skols+pprTcSolverReportMsg _ (UserTypeError ty) =+  pprUserTypeErrorTy ty+pprTcSolverReportMsg _ (UnsatisfiableError ty) =+  pprUserTypeErrorTy ty+pprTcSolverReportMsg ctxt (ReportHoleError hole err) =+  pprHoleError ctxt hole err+pprTcSolverReportMsg ctxt+  (CannotUnifyVariable+    { mismatchMsg         = msg+    , cannotUnifyReason   = reason })+  =  pprMismatchMsg ctxt msg+  $$ pprCannotUnifyVariableReason ctxt reason+pprTcSolverReportMsg ctxt+  (Mismatch+     { mismatchMsg           = mismatch_msg+     , mismatchTyVarInfo     = tv_info+     , mismatchAmbiguityInfo = ambig_infos+     , mismatchCoercibleInfo = coercible_info })+  = vcat ([ pprMismatchMsg ctxt mismatch_msg+          , maybe empty (pprTyVarInfo ctxt) tv_info+          , maybe empty pprCoercibleMsg coercible_info ]+          ++ (map pprAmbiguityInfo ambig_infos))+pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =+  vcat (map make_msg frr_origs)+  where+    -- Assemble the error message: pair up each origin with the corresponding type, e.g.+    --   • FixedRuntimeRep origin msg 1 ...+    --       a :: TYPE r1+    --   • FixedRuntimeRep origin msg 2 ...+    --       b :: TYPE r2+    make_msg :: FixedRuntimeRepErrorInfo -> SDoc+    make_msg (FRR_Info { frr_info_origin =+                           FixedRuntimeRepOrigin+                             { frr_type    = ty+                             , frr_context = frr_ctxt }+                       , frr_info_not_concrete =+                         mb_not_conc }) =+      -- Add bullet points if there is more than one error.+      (if length frr_origs > 1 then (bullet <+>) else id) $+        vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt+                   , text "does not have a fixed runtime representation." ]+             , type_printout ty+             , case mb_not_conc of+                Nothing -> empty+                Just (conc_tv, not_conc) ->+                  unsolved_concrete_eq_explanation conc_tv not_conc ]++    -- Don't print out the type (only the kind), if the type includes+    -- a confusing cast, unless the user passed -fprint-explicit-coercions.+    --+    -- Example:+    --+    --   In T20363, we have a representation-polymorphism error with a type+    --   of the form+    --+    --     ( (# #) |> co ) :: TYPE NilRep+    --+    --   where NilRep is a nullary type family application which reduces to TupleRep '[].+    --   We prefer avoiding showing the cast to the user, but we also don't want to+    --   print the confusing:+    --+    --     (# #) :: TYPE NilRep+    --+    --  So in this case we simply don't print the type, only the kind.+    confusing_cast :: Type -> Bool+    confusing_cast ty =+      case ty of+        CastTy inner_ty _+          -- A confusing cast is one that is responsible+          -- for a representation-polymorphism error.+          -> isConcreteType (typeKind inner_ty)+        _ -> False++    type_printout :: Type -> SDoc+    type_printout ty =+      sdocOption sdocPrintExplicitCoercions $ \ show_coercions ->+        if  confusing_cast ty && not show_coercions+        then vcat [ text "Its kind is:"+                  , nest 2 $ pprWithTYPE (typeKind ty)+                  , text "(Use -fprint-explicit-coercions to see the full type.)" ]+        else vcat [ text "Its type is:"+                  , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ]++    unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc+    unsolved_concrete_eq_explanation tv not_conc =+          text "Cannot unify" <+> quotes (ppr not_conc)+      <+> text "with the type variable" <+> quotes (ppr tv)+      $$  text "because 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 _ (BlockedEquality item) =+  vcat [ hang (text "Cannot use equality for substitution:")+           2 (ppr (errorItemPred item))+       , text "Doing so would be ill-kinded." ]+pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =+  text "Expecting" <+> speakN (abs n) <+>+    more <+> quotes (ppr thing)+  where+    more+     | n == 1    = text "more argument to"+     | otherwise = text "more arguments to" -- n > 1+pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =+  let givens = getUserGivens ctxt+  in if null givens+     then addArising (errorItemCtLoc item) $+            sep [ text "Unbound implicit parameter" <> plural preds+                , nest 2 (pprParendTheta preds) ]+     else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)+  where+    preds = map errorItemPred (item : items)+pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) =+  pprAmbiguityInfo (Ambiguity True ambigs) <+>+  pprArising (errorItemCtLoc item) $$+  text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)+  <+> text "from being solved."+pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})+  (CannotResolveInstance item unifiers candidates imp_errs suggs binds)+  =+    vcat+      [ no_inst_msg+      , nest 2 extra_note+      , mb_patsyn_prov `orElse` empty+      , ppWhen (has_ambigs && not (null unifiers && null useful_givens))+        (vcat [ ppUnless lead_with_ambig $+                  pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs))+              , pprRelevantBindings binds+              , potential_msg ])+      , ppWhen (isNothing mb_patsyn_prov) $+            -- Don't suggest fixes for the provided context of a pattern+            -- synonym; the right fix is to bind more in the pattern+        show_fixes (ctxtFixes has_ambigs pred implics+                    ++ drv_fixes ++ naked_sc_fixes)+      , ppWhen (not (null candidates))+        (hang (text "There are instances for similar types:")+            2 (vcat (map ppr candidates)))+            -- See Note [Report candidate instances]+      , vcat $ map ppr imp_errs+      , vcat $ map ppr suggs ]+  where+    orig          = errorItemOrigin item+    pred          = errorItemPred item+    (clas, tys)   = getClassPredTys pred+    -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors+    (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred+    ambigs = ambig_kvs ++ ambig_tvs+    has_ambigs = not (null ambigs)+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+         -- useful_givens are the enclosing implications with non-empty givens,+         -- modulo the horrid discardProvCtxtGivens+    lead_with_ambig = not (null ambigs)+                   && not (any isRuntimeUnkSkol ambigs)+                   && not (null unifiers)+                   && null useful_givens++    no_inst_msg :: SDoc+    no_inst_msg+      | lead_with_ambig+      = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs)+      | otherwise+      = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing++    -- Report "potential instances" only when the constraint arises+    -- directly from the user's use of an overloaded function+    want_potential (TypeEqOrigin {}) = False+    want_potential _                 = True++    potential_msg+      = ppWhen (not (null unifiers) && want_potential orig) $+          potential_hdr $$+          potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers })++    potential_hdr+      = ppWhen lead_with_ambig $+        text "Probable fix: use a type annotation to specify what"+        <+> pprQuotedList ambig_tvs <+> text "should be."++    mb_patsyn_prov :: Maybe SDoc+    mb_patsyn_prov+      | not lead_with_ambig+      , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig+      = Just (vcat [ text "In other words, a successful match on the pattern"+                   , nest 2 $ ppr pat+                   , text "does not provide the constraint" <+> pprParendType pred ])+      | otherwise = Nothing++    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)+               = text "(maybe you haven't applied a function to enough arguments?)"+               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)+               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))+               , Just (tc,_) <- tcSplitTyConApp_maybe ty+               , not (isTypeFamilyTyCon tc)+               = hang (text "GHC can't yet do polykinded")+                    2 (text "Typeable" <+>+                       parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))+               | otherwise+               = empty++    drv_fixes = case orig of+                   DerivClauseOrigin                  -> [drv_fix False]+                   StandAloneDerivOrigin              -> [drv_fix True]+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]+                   _                                  -> []++    drv_fix standalone_wildcard+      | standalone_wildcard+      = text "fill in the wildcard constraint yourself"+      | otherwise+      = hang (text "use a standalone 'deriving instance' declaration,")+           2 (text "so you can specify the instance context yourself")++    -- naked_sc_fix: try to produce a helpful error message for+    -- superclass constraints caught by the subtleties described by+    -- Note [Recursive superclasses] in GHC.TyCl.Instance+    naked_sc_fixes+      | ScOrigin _ NakedSc <- orig  -- A superclass wanted with no instance decls used yet+      , any non_tyvar_preds useful_givens  -- Some non-tyvar givens+      = [vcat [ text "If the constraint looks soluble from a superclass of the instance context,"+              , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]]+      | otherwise = []++    non_tyvar_preds :: UserGiven -> Bool+    non_tyvar_preds = any non_tyvar_pred . ic_given++    non_tyvar_pred :: EvVar -> Bool+    -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars+    non_tyvar_pred given = case getClassPredTys_maybe (idType given) of+                             Just (_, tys) -> not (all isTyVarTy tys)+                             Nothing       -> False++pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =+  vcat+    [ addArising ct_loc $+        (text "Overlapping instances for"+        <+> pprType (mkClassPred clas tys))+    , ppUnless (null matching_givens) $+                  sep [text "Matching givens (or their superclasses):"+                      , nest 2 (vcat matching_givens)]+    ,  potentialInstancesErrMsg+        (PotentialInstances { matches = NE.toList matches, unifiers })+    ,  ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $+       -- Intuitively, some given matched the wanted in their+       -- flattened or rewritten (from given equalities) form+       -- but the matcher can't figure that out because the+       -- constraints are non-flat and non-rewritten so we+       -- simply report back the whole given+       -- context. Accelerate Smart.hs showed this problem.+         sep [ text "There exists a (perhaps superclass) match:"+             , nest 2 (vcat (pp_givens useful_givens))]++    ,  ppWhen (null $ NE.tail matches) $+       parens (vcat [ ppUnless (null tyCoVars) $+                        text "The choice depends on the instantiation of" <+>+                          quotes (pprWithCommas ppr tyCoVars)+                    , ppUnless (null famTyCons) $+                        if (null tyCoVars)+                          then+                            text "The choice depends on the result of evaluating" <+>+                              quotes (pprWithCommas ppr famTyCons)+                          else+                            text "and the result of evaluating" <+>+                              quotes (pprWithCommas ppr famTyCons)+                    , ppWhen (null (matching_givens)) $+                      vcat [ text "To pick the first instance above, use IncoherentInstances"+                           , text "when compiling the other instance declarations"]+               ])]+  where+    ct_loc          = errorItemCtLoc item+    orig            = ctLocOrigin ct_loc+    pred            = errorItemPred item+    (clas, tys)     = getClassPredTys pred+    tyCoVars        = tyCoVarsOfTypesList tys+    famTyCons       = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys+    useful_givens   = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+    matching_givens = mapMaybe matchable useful_givens+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })+      = case ev_vars_matching of+             [] -> Nothing+             _  -> Just $ hang (pprTheta ev_vars_matching)+                            2 (sep [ text "bound by" <+> ppr skol_info+                                   , text "at" <+>+                                     ppr (getCtLocEnvLoc (ic_env implic)) ])+        where ev_vars_matching = [ pred+                                 | ev_var <- evvars+                                 , let pred = evVarPred ev_var+                                 , any can_match (pred : transSuperClasses pred) ]+              can_match pred+                 = case getClassPredTys_maybe pred of+                     Just (clas', tys') -> clas' == clas+                                          && isJust (tcMatchTys tys tys')+                     Nothing -> False+pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) =+  vcat [ addArising ct_loc (text "Unsafe overlapping instances for"+                  <+> pprType (mkClassPred clas tys))+       , sep [text "The matching instance is:",+              nest 2 (pprInstance match)]+       , vcat [ text "It is compiled in a Safe module and as such can only"+              , text "overlap instances from the same module, however it"+              , text "overlaps the following instances from different" <+>+                text "modules:"+              , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped])+              ]+       ]+  where+    ct_loc      = errorItemCtLoc item+    pred        = errorItemPred item+    (clas, tys) = getClassPredTys pred++pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc+pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) =+  vcat [ (if isSkolemTyVar tv1+          then text "Cannot equate type variable"+          else text "Cannot instantiate unification variable")+         <+> quotes (ppr tv1)+       , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2)+       , maybe empty (pprTyVarInfo ctxt) mb_tv_info ]+  where+    what = text $ levelString $+           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel++pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) =+  let+    esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols+                <+> pprQuotedList esc_skols+              , text "would escape" <+>+                if isSingleton esc_skols then text "its scope"+                                         else text "their scope" ]+  in+  vcat [ nest 2 $ esc_doc+       , sep [ (if isSingleton esc_skols+                then text "This (rigid, skolem)" <+>+                     what <+> text "variable is"+                else text "These (rigid, skolem)" <+>+                     what <+> text "variables are")+         <+> text "bound by"+       , nest 2 $ ppr (ic_info implic)+       , nest 2 $ text "at" <+>+         ppr (getCtLocEnvLoc (ic_env implic)) ] ]+  where+    what = text $ levelString $+           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel++pprCannotUnifyVariableReason ctxt+  (OccursCheck+    { occursCheckInterestingTyVars = interesting_tvs+    , occursCheckAmbiguityInfos    = ambig_infos })+  = ppr_interesting_tyVars interesting_tvs+  $$ vcat (map pprAmbiguityInfo ambig_infos)+  where+    ppr_interesting_tyVars [] = empty+    ppr_interesting_tyVars (tv:tvs) =+      hang (text "Type variable kinds:") 2 $+      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))+                (tv:tvs))+    tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)+pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info)+  = pprTyVarInfo ctxt tv_info+pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg)+  = pprTyVarInfo ctxt tv_info+  $$ maybe empty pprCoercibleMsg mb_coercible_msg++pprUntouchableVariable :: TcTyVar -> Implication -> SDoc+pprUntouchableVariable tv (Implic { ic_given = given, ic_info = skol_info, ic_env = env })+  = sep [ quotes (ppr tv) <+> text "is untouchable"+        , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given+        , nest 2 $ text "bound by" <+> ppr skol_info+        , nest 2 $ text "at" <+> ppr (getCtLocEnvLoc env) ]++pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc+pprMismatchMsg ctxt+  (BasicMismatch { mismatch_ea   = ea+                 , mismatch_item = item+                 , mismatch_ty1  = ty1  -- Expected+                 , mismatch_ty2  = ty2  -- Actual+                 , mismatch_whenMatching = mb_match_txt+                 , mismatch_mb_same_occ  = same_occ_info })+  =  vcat [ addArising (errorItemCtLoc item) msg+          , ea_extra+          , maybe empty (pprWhenMatching ctxt) mb_match_txt+          , maybe empty pprSameOccInfo same_occ_info ]+  where+    msg+      | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||+        (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||+        (isLiftedLevity ty1 && isUnliftedLevity ty2) ||+        (isLiftedLevity ty2 && isUnliftedLevity ty1)+      = text "Couldn't match a lifted type with an unlifted type"++      | isAtomicTy ty1 || isAtomicTy ty2+      = -- Print with quotes+        sep [ text herald1 <+> quotes (ppr ty1)+            , nest padding $+              text herald2 <+> quotes (ppr ty2) ]++      | otherwise+      = -- Print with vertical layout+        vcat [ text herald1 <> colon <+> ppr ty1+             , nest padding $+               text herald2 <> colon <+> ppr ty2 ]++    herald1 = conc [ "Couldn't match"+                   , if is_repr then "representation of" else ""+                   , if want_ea then "expected"          else ""+                   , what ]+    herald2 = conc [ "with"+                   , if is_repr then "that of"           else ""+                   , if want_ea then ("actual " ++ what) else "" ]++    padding = length herald1 - length herald2++    (want_ea, ea_extra)+      = case ea of+         NoEA        -> (False, empty)+         EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra)+    is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False }++    what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel)++    conc :: [String] -> String+    conc = foldr1 add_space++    add_space :: String -> String -> String+    add_space s1 s2 | null s1   = s2+                    | null s2   = s1+                    | otherwise = s1 ++ (' ' : s2)+pprMismatchMsg _+  (KindMismatch { kmismatch_what     = thing+                , kmismatch_expected = exp+                , kmismatch_actual   = act })+  = hang (text "Expected" <+> kind_desc <> comma)+      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>+        quotes (ppr act))+  where+    kind_desc | isConstraintLikeKind exp = text "a constraint"+              | Just arg <- kindRep_maybe exp  -- TYPE t0+              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case+                                   True  -> text "kind" <+> quotes (ppr exp)+                                   False -> text "a type"+              | otherwise       = text "kind" <+> quotes (ppr exp)++pprMismatchMsg ctxt+  (TypeEqMismatch { teq_mismatch_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, 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) =+  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))+    NotARecordField ->+      hang (text "Not in scope:")+        2 (text "record field" <+> quotes (ppr rdr_name))+    NoExactName name ->+      text "The Name" <+> quotes (ppr name) <+> text "is not in scope."+    SameName gres ->+      assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres))+      $ hang (text "Same Name in multiple name-spaces:")+           2 (vcat (map pp_one sorted_names))+      where+        sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan)+                     $ map greName gres+        pp_one name+          = hang (pprNameSpace (occNameSpace (getOccName name))+                  <+> quotes (ppr name) <> comma)+               2 (text "declared at:" <+> ppr (nameSrcLoc name))+    MissingBinding thing _ ->+      sep [ text "The" <+> thing+               <+> text "for" <+> quotes (ppr rdr_name)+          , nest 2 $ text "lacks an accompanying binding" ]+    NoTopLevelBinding ->+      hang (text "No top-level binding for")+        2 (what <+> quotes (ppr rdr_name) <+> text "in this module")+    UnknownSubordinate doc ->+      quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc+    NotInScopeTc env ->+      vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+>+      text "is not in scope during type checking, but it passed the renamer",+      text "tcl_env of environment:" <+> ppr env]+  where+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))++scopeErrorHints :: NotInScopeError -> [GhcHint]+scopeErrorHints scope_err =+  case scope_err of+    NotInScope             -> noHints+    NotARecordField        -> noHints+    NoExactName {}         -> [SuggestDumpSlices]+    SameName {}            -> [SuggestDumpSlices]+    MissingBinding _ hints -> hints+    NoTopLevelBinding      -> noHints+    UnknownSubordinate {}  -> noHints+    NotInScopeTc _         -> noHints++{- *********************************************************************+*                                                                      *+                  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 (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 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 ->+    quotes (text "RecGadtC") <+> text "must have at least one constructor name"+  GadtNoCons ->+    quotes (text "GadtC") <+> text "must have at least one constructor name"+  InvalidTypeInstanceHeader tys ->+    text "Invalid type instance header:"+    <+> text (show tys)+  InvalidTyFamInstLHS lhs ->+    text "Invalid type family instance LHS:"+    <+> text (show lhs)+  InvalidImplicitParamBinding ->+    text "Implicit parameter binding only allowed in let or where"+  DefaultDataInstDecl adts ->+    (text "Default data instance declarations"+    <+> text "are not allowed:")+      $$ ppr adts+  FunBindLacksEquations nm ->+    text "Function binding for"+    <+> quotes (text (TH.pprint nm))+    <+> text "has no equations"++pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc+pprTyThingUsedWrong sort thing name =+  pprTcTyThingCategory thing <+> quotes (ppr name) <+>+  text "used as a" <+> pprWrongThingSort sort++pprWrongThingSort :: WrongThingSort -> SDoc+pprWrongThingSort =+  text . \case+    WrongThingType -> "type"+    WrongThingDataCon -> "data constructor"+    WrongThingPatSyn -> "pattern synonym"+    WrongThingConLike -> "constructor-like thing"+    WrongThingClass -> "class"+    WrongThingTyCon -> "type constructor"+    WrongThingAxiom -> "axiom"++pprStageCheckReason :: StageCheckReason -> SDoc+pprStageCheckReason = \case+  StageCheckInstance _ t ->+    text "instance for" <+> quotes (ppr t)+  StageCheckSplice t ->+    quotes (ppr t)++pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc+pprUninferrableTyVarCtx = \case+  UninfTyCtx_ClassContext theta ->+    sep [ text "the class context:", pprTheta theta ]+  UninfTyCtx_DataContext theta ->+    sep [ text "the datatype context:", pprTheta theta ]+  UninfTyCtx_ProvidedContext theta ->+    sep [ text "the provided context:" , pprTheta theta ]+  UninfTyCtx_TyFamRhs rhs_ty ->+    sep [ text "the type family equation right-hand side:" , ppr rhs_ty ]+  UninfTyCtx_TySynRhs rhs_ty ->+    sep [ text "the type synonym right-hand side:" , ppr rhs_ty ]+  UninfTyCtx_Sig exp_kind full_hs_ty ->+    hang (text "the kind" <+> ppr exp_kind) 2+         (text "of the type signature:" <+> ppr full_hs_ty)++pprPatSynInvalidRhsReason :: PatSynInvalidRhsReason -> SDoc+pprPatSynInvalidRhsReason = \case+  PatSynNotInvertible p ->+    text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"+  PatSynUnboundVar var ->+    quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"++pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc+pprBadFieldAnnotationReason = \case+  LazyFieldsDisabled ->+    text "Lazy field annotations (~) are disabled"+  UnpackWithoutStrictness ->+    text "UNPACK pragma lacks '!'"+  BackpackUnpackAbstractType ->+    text "Ignoring unusable UNPACK pragma"++pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc+pprSuperclassCycleDetail = \case+  SCD_HeadTyVar pred ->+    hang (text "one of whose superclass constraints is headed by a type variable:")+       2 (quotes (ppr pred))+  SCD_HeadTyFam pred ->+    hang (text "one of whose superclass constraints is headed by a type family:")+       2 (quotes (ppr pred))+  SCD_Superclass cls ->+    text "one of whose superclasses is" <+> quotes (ppr cls)++pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc+pprRoleValidationFailedReason role = \case+  TyVarRoleMismatch tv role' ->+    text "type variable" <+> quotes (ppr tv) <+>+    text "cannot have role" <+> ppr role <+>+    text "because it was assigned role" <+> ppr role'+  TyVarMissingInEnv tv ->+    text "type variable" <+> quotes (ppr tv) <+> text "missing in environment"+  BadCoercionRole co ->+    text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role++pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc+pprDisabledClassExtension cls = \case+  MultiParamDisabled n ->+    text howMany <+> text "parameters for class" <+> quotes (ppr cls)+    where+      howMany | n == 0 = "No"+              | otherwise = "Too many"+  FunDepsDisabled ->+    text "Fundeps in class" <+> quotes (ppr cls)+  ConstrainedClassMethodsDisabled sel_id pred ->+    vcat [ hang (text "Constraint" <+> quotes (ppr pred)+                 <+> text "in the type of" <+> quotes (ppr sel_id))+              2 (text "constrains only the class type variables")]++pprImportLookup :: ImportLookupReason -> SDoc+pprImportLookup = \case+  ImportLookupBad k iface decl_spec ie _ps ->+    let+      pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc+      pprImpDeclSpec iface decl_spec =+        quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of+            IsBoot  -> text "(hi-boot interface)"+            NotBoot -> empty+      withContext msgs =+        hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon)+          2 (vcat msgs)+    in case k of+      BadImportNotExported _ ->+        vcat+          [ text "Module" <+> pprImpDeclSpec iface decl_spec <+>+            text "does not export" <+> quotes (ppr ie) <> dot+          ]+      BadImportAvailVar ->+        withContext+          [ text "an item called"+              <+> quotes val <+> text "is exported, but it is not a type."+          ]+        where+          val_occ = rdrNameOcc $ ieName ie+          val = parenSymOcc val_occ (ppr val_occ)+      BadImportAvailTyCon {} ->+        withContext+          [ text "an item called"+            <+> quotes tycon <+> text "is exported, but it is a type."+          ]+        where+          tycon_occ = rdrNameOcc $ ieName ie+          tycon = parenSymOcc tycon_occ (ppr tycon_occ)+      BadImportNotExportedSubordinates ns ->+        withContext+          [ text "an item called" <+> quotes sub <+> text "is exported, but it does not export any children"+          , text "(constructors, class methods or field names) called"+          <+> pprWithCommas (quotes . ppr) ns <> dot+          ]+          where+            sub_occ = rdrNameOcc $ ieName ie+            sub = parenSymOcc sub_occ (ppr sub_occ)+      BadImportAvailDataCon dataType_occ ->+        withContext+          [ text "an item called" <+> quotes datacon+          , text "is exported, but it is a data constructor of"+          , quotes dataType <> dot+          ]+          where+            datacon_occ = rdrNameOcc $ ieName ie+            datacon = parenSymOcc datacon_occ (ppr datacon_occ)+            dataType = parenSymOcc dataType_occ (ppr dataType_occ)+  ImportLookupQualified rdr ->+    hang (text "Illegal qualified name in import item:")+       2 (ppr rdr)+  ImportLookupIllegal ->+    text "Illegal import item"+  ImportLookupAmbiguous rdr gres ->+    hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")+       2 (vcat (map (ppr . greOccName) gres))++pprUnusedImport :: ImportDecl GhcRn -> UnusedImportReason -> SDoc+pprUnusedImport decl = \case+  UnusedImportNone ->+    vcat [ pp_herald <+> quotes pp_mod <+> text "is redundant"+         , nest 2 (text "except perhaps to import instances from"+                   <+> quotes pp_mod)+         , text "To import instances alone, use:"+           <+> text "import" <+> pp_mod <> parens empty ]+  UnusedImportSome sort_unused ->+    sep [ pp_herald <+> quotes (pprWithCommas pp_unused sort_unused)+        , text "from module" <+> quotes pp_mod <+> text "is redundant"]+  where+    pp_mod = ppr (unLoc (ideclName decl))+    pp_herald = text "The" <+> pp_qual <+> text "import of"+    pp_qual+      | isImportDeclQualified (ideclQualified decl) = text "qualified"+      | otherwise                                   = empty+    pp_unused = \case+      UnusedImportNameRegular n ->+        pprNameUnqualified n+      UnusedImportNameRecField par fld_occ ->+        case par of+          ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ)+          NoParent   -> ppr fld_occ++pprUnusedName :: OccName -> UnusedNameProv -> SDoc+pprUnusedName name reason =+  sep [ msg <> colon+      , nest 2 $ pprNonVarNameSpace (occNameSpace name)+                 <+> quotes (ppr name)]+  where+    msg = case reason of+      UnusedNameTopDecl ->+        defined+      UnusedNameImported mod ->+        text "Imported from" <+> quotes (ppr mod) <+> text "but not used"+      UnusedNameTypePattern ->+        defined <+> text "on the right hand side"+      UnusedNameMatch ->+        defined+      UnusedNameLocalBind ->+        defined+    defined = text "Defined but not used"++-- When printing the name, take care to qualify it in the same+-- way as the provenance reported by pprNameProvenance, namely+-- the head of 'gre_imp'.  Otherwise we get confusing reports like+--   Ambiguous occurrence ‘null’+--   It could refer to either ‘T15487a.null’,+--                            imported from ‘Prelude’ at T15487.hs:1:8-13+--                     or ...+-- See #15487+pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc+pprAmbiguousGreName gre_env gre+  | IAmRecField fld_info <- greInfo gre+  = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma+        , pprNameProvenance gre ]+  | otherwise+  = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma+        , pprNameProvenance gre ]++  where+    occ = greOccName gre+    parent_info fld_info =+      case first_con of+        PatSynName  ps -> text "of pattern synonym" <+> quotes (ppr ps)+        DataConName {} ->+          case greParent gre of+            ParentIs par+              -- For a data family, only reporting the family TyCon can be+              -- unhelpful (see T23301). So we give a bit of additional+              -- info in that case.+              | Just par_gre <- lookupGRE_Name gre_env par+              , IAmTyCon tc_flav <- greInfo par_gre+              , OpenFamilyFlavour IAmData _ <- tc_flav+              -> vcat [ ppr_cons+                      , text "in a data family instance of" <+> quotes (ppr par) ]+              | otherwise+              -> text "of record" <+> quotes (ppr par)+            NoParent -> ppr_cons+      where+        cons :: [ConLikeName]+        cons = nonDetEltsUniqSet $ recFieldCons fld_info+        first_con :: ConLikeName+        first_con = head cons+        ppr_cons :: SDoc+        ppr_cons = hsep [ text "belonging to data constructor"+                        , quotes (ppr $ nameOccName $ conLikeName_Name first_con)+                        , if length cons > 1 then parens (text "among others") else empty+                        ]+    pp_qual+        | gre_lcl gre+        = ppr (nameModule $ greName gre)+        | Just imp  <- headMaybe $ gre_imp gre+            -- This 'imp' is the one that+            -- pprNameProvenance chooses+        , ImpDeclSpec { is_as = mod } <- is_decl imp+        = ppr mod+        | otherwise+        = pprPanic "addNameClassErrRn" (ppr gre)+          -- Invariant: either 'lcl' is True or 'iss' is non-empty++pprNonCanonicalDefinition :: LHsSigType GhcRn+                          -> NonCanonicalDefinition+                          -> SDoc+pprNonCanonicalDefinition inst_ty = \case+  NonCanonicalMonoid sub -> case sub of+    NonCanonical_Sappend ->+      msg1 "(<>)" "mappend"+    NonCanonical_Mappend ->+      msg2 "mappend" "(<>)"+  NonCanonicalMonad sub -> case sub of+    NonCanonical_Pure ->+      msg1 "pure" "return"+    NonCanonical_ThenA ->+      msg1 "(*>)" "(>>)"+    NonCanonical_Return ->+      msg2 "return" "pure"+    NonCanonical_ThenM ->+      msg2 "(>>)" "(*>)"+  where+    msg1 :: String -> String -> SDoc+    msg1 lhs rhs =+      vcat [ text "Noncanonical" <+>+            quotes (text (lhs ++ " = " ++ rhs)) <+>+            text "definition detected"+          , inst+          ]++    msg2 :: String -> String -> SDoc+    msg2 lhs rhs =+      vcat [ text "Noncanonical" <+>+            quotes (text lhs) <+>+            text "definition detected"+          , inst+          , quotes (text lhs) <+>+            text "will eventually be removed in favour of" <+>+            quotes (text rhs)+          ]++    inst = instDeclCtxt1 inst_ty++    -- stolen from GHC.Tc.TyCl.Instance+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+    instDeclCtxt1 hs_inst_ty+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++    inst_decl_ctxt :: SDoc -> SDoc+    inst_decl_ctxt doc = hang (text "in the instance declaration for")+                         2 (quotes doc <> text ".")++suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint]+suggestNonCanonicalDefinition reason =+  [action doc]+  where+    action = case reason of+      NonCanonicalMonoid sub -> case sub of+        NonCanonical_Sappend -> move sappendName mappendName+        NonCanonical_Mappend -> remove mappendName sappendName+      NonCanonicalMonad sub -> case sub of+        NonCanonical_Pure -> move pureAName returnMName+        NonCanonical_ThenA -> move thenAName thenMName+        NonCanonical_Return -> remove returnMName pureAName+        NonCanonical_ThenM -> remove thenMName thenAName++    move = SuggestMoveNonCanonicalDefinition+    remove = SuggestRemoveNonCanonicalDefinition++    doc = case reason of+      NonCanonicalMonoid _ -> doc_monoid+      NonCanonicalMonad _ -> doc_monad++    doc_monoid =+      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"+    doc_monad =+      "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"++--------------------------------------------------------------------------------+-- 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 text "NB: roles on abstract types default to" <+>+           quotes (text "representational") <+> text "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 ->+    pprWithExplicitKindsWhen invis_arg $+      hang (text "Illegal type synonym family application"+              <+> quotes (ppr tf_ty) <+> text "in instance" <> colon)+         2 (ppr inst_ty)+      where+        tf_ty = mkTyConApp tf_tc tf_args++pprIllegalClassInstanceReason :: TypedThing -> IllegalClassInstanceReason -> SDoc+pprIllegalClassInstanceReason head_ty = \case+  IllegalInstanceHead reason ->+    pprIllegalInstanceHeadReason head_ty reason+  IllegalHasFieldInstance has_field_err ->+    with_illegal_instance_header head_ty $+      pprIllegalHasFieldInstance has_field_err+  IllegalSpecialClassInstance cls because_safeHaskell ->+    text "Class" <+> quotes (ppr $ className cls)+    <+> text "does not support user-specified instances"+    <> safeHaskell_msg+      where+        safeHaskell_msg+          | because_safeHaskell+          = text " when Safe Haskell is enabled."+          | otherwise+          = dot+  IllegalInstanceFailsCoverageCondition cls coverage_failure ->+    with_illegal_instance_header head_ty $+      pprNotCovered cls coverage_failure++pprIllegalInstanceHeadReason :: TypedThing+                             -> IllegalInstanceHeadReason -> SDoc+pprIllegalInstanceHeadReason head_ty = \case+  InstHeadTySynArgs -> with_illegal_instance_header head_ty $+    text "All instance types must be of the form (T t1 ... tn)" $$+    text "where T is not a synonym."+  InstHeadNonTyVarArgs -> with_illegal_instance_header head_ty $ vcat [+    text "All instance types must be of the form (T a1 ... an)",+    text "where a1 ... an are *distinct type variables*,",+    text "and each type variable appears at most once in the instance head."]+  InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $+    text "Only one type can be given in an instance head."+  InstHeadAbstractClass clas ->+    text "Cannot define instance for abstract class" <+>+    quotes (ppr (className clas))+  InstHeadNonClass bad_head ->+    vcat [ text "Illegal" <+> what_illegal <> dot+         , text "Instance heads must be of the form"+         , nest 2 $ text "C ty_1 ... ty_n"+         , text "where" <+> quotes (char 'C') <+> text "is a class."+         ]+    where+      what_illegal = case bad_head of+        Just tc ->+          text "instance for" <+> ppr (tyConFlavour tc) <+> quotes (ppr $ tyConName tc)+        Nothing ->+          text "head of an instance declaration:" <+> quotes (ppr head_ty)++with_illegal_instance_header :: TypedThing -> SDoc -> SDoc+with_illegal_instance_header head_ty msg =+  hang (hang (text "Illegal instance declaration for")+           2 (quotes (ppr head_ty)) <> colon)+      2 msg++pprIllegalHasFieldInstance :: IllegalHasFieldInstance -> SDoc+pprIllegalHasFieldInstance = \case+  IllegalHasFieldInstanceNotATyCon+    -> text "Record data type must be specified."+  IllegalHasFieldInstanceFamilyTyCon+    -> text "Record data type may not be a data family."+  IllegalHasFieldInstanceTyConHasField tc lbl+    -> quotes (ppr tc) <+> text "already has a field" <+> quotes (ppr lbl) <> dot+  IllegalHasFieldInstanceTyConHasFields tc lbl+    -> sep [ ppr_tc <+> text "has fields, and the type" <+> quotes (ppr lbl)+           , text "could unify with one of the field labels of" <+> ppr_tc <> dot ]+    where ppr_tc = quotes (ppr tc)++pprNotCovered :: Class -> CoverageProblem -> SDoc+pprNotCovered clas+  CoverageProblem+  { not_covered_fundep        = fd+  , not_covered_fundep_inst   = (ls, rs)+  , not_covered_invis_vis_tvs = undetermined_tvs+  , not_covered_liberal       = which_cc_failed+  } =+  pprWithExplicitKindsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $+    vcat [ sep [ text "The"+                  <+> ppWhen liberal (text "liberal")+                  <+> text "coverage condition fails in class"+                  <+> quotes (ppr clas)+                , nest 2 $ text "for functional dependency:"+                  <+> quotes (pprFunDep fd) ]+          , sep [ text "Reason: lhs type" <> plural ls <+> pprQuotedList ls+                , nest 2 $+                  (if isSingleton ls+                  then text "does not"+                  else text "do not jointly")+                  <+> text "determine rhs type" <> plural rs+                  <+> pprQuotedList rs ]+          , text "Un-determined variable" <> pluralVarSet undet_set <> colon+                  <+> pprVarSet undet_set (pprWithCommas ppr)+          ]+  where+    liberal = case which_cc_failed of+                   FailedLICC   -> True+                   FailedICC {} -> False+    undet_set = fold undetermined_tvs++illegalInstanceHints :: IllegalInstanceReason -> [GhcHint]+illegalInstanceHints = \case+  IllegalClassInstance _ reason ->+    illegalClassInstanceHints reason+  IllegalFamilyInstance reason ->+    illegalFamilyInstanceHints reason+  IllegalFamilyApplicationInInstance {} ->+    noHints++illegalInstanceReason :: IllegalInstanceReason -> DiagnosticReason+illegalInstanceReason = \case+  IllegalClassInstance _ reason ->+    illegalClassInstanceReason reason+  IllegalFamilyInstance reason ->+    illegalFamilyInstanceReason reason+  IllegalFamilyApplicationInInstance {} ->+    ErrorWithoutFlag++illegalClassInstanceHints :: IllegalClassInstanceReason -> [GhcHint]+illegalClassInstanceHints = \case+  IllegalInstanceHead reason ->+    illegalInstanceHeadHints reason+  IllegalHasFieldInstance has_field_err ->+    illegalHasFieldInstanceHints has_field_err+  IllegalSpecialClassInstance {} -> noHints+  IllegalInstanceFailsCoverageCondition _ coverage_failure ->+    failedCoverageConditionHints coverage_failure+++illegalClassInstanceReason :: IllegalClassInstanceReason -> DiagnosticReason+illegalClassInstanceReason = \case+  IllegalInstanceHead reason ->+    illegalInstanceHeadReason reason+  IllegalHasFieldInstance has_field_err ->+    illegalHasFieldInstanceReason has_field_err+  IllegalSpecialClassInstance {} -> ErrorWithoutFlag+  IllegalInstanceFailsCoverageCondition _ coverage_failure ->+    failedCoverageConditionReason coverage_failure++illegalInstanceHeadHints :: IllegalInstanceHeadReason -> [GhcHint]+illegalInstanceHeadHints = \case+  InstHeadTySynArgs ->+    [suggestExtension LangExt.TypeSynonymInstances]+  InstHeadNonTyVarArgs ->+    [suggestExtension LangExt.FlexibleInstances]+  InstHeadMultiParam ->+    [suggestExtension LangExt.MultiParamTypeClasses]+  InstHeadAbstractClass {} ->+    noHints+  InstHeadNonClass {} ->+    noHints++illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason+illegalInstanceHeadReason = \case+  -- These are serious+  InstHeadAbstractClass {} ->+    ErrorWithoutFlag+  InstHeadNonClass {} ->+    ErrorWithoutFlag++  -- These are less serious (enable an extension)+  InstHeadTySynArgs ->+    ErrorWithoutFlag+  InstHeadNonTyVarArgs ->+    ErrorWithoutFlag+  InstHeadMultiParam ->+    ErrorWithoutFlag++illegalHasFieldInstanceHints :: IllegalHasFieldInstance -> [GhcHint]+illegalHasFieldInstanceHints = \case+  IllegalHasFieldInstanceNotATyCon+    -> noHints+  IllegalHasFieldInstanceFamilyTyCon+    -> noHints+  IllegalHasFieldInstanceTyConHasField {}+    -> noHints+  IllegalHasFieldInstanceTyConHasFields {}+    -> noHints++illegalHasFieldInstanceReason :: IllegalHasFieldInstance -> DiagnosticReason+illegalHasFieldInstanceReason = \case+  IllegalHasFieldInstanceNotATyCon+    -> ErrorWithoutFlag+  IllegalHasFieldInstanceFamilyTyCon+    -> ErrorWithoutFlag+  IllegalHasFieldInstanceTyConHasField {}+    -> ErrorWithoutFlag+  IllegalHasFieldInstanceTyConHasFields {}+    -> ErrorWithoutFlag++failedCoverageConditionHints :: CoverageProblem -> [GhcHint]+failedCoverageConditionHints (CoverageProblem { not_covered_liberal = failed_cc })+  = case failed_cc of+      FailedLICC -> noHints+      FailedICC { alsoFailedLICC = failed_licc } ->+        -- Turning on UndecidableInstances makes the check liberal,+        -- so if the liberal check passes, suggest enabling UndecidableInstances.+        if failed_licc+        then noHints+        else [suggestExtension LangExt.UndecidableInstances]++failedCoverageConditionReason :: CoverageProblem -> DiagnosticReason+failedCoverageConditionReason _ = ErrorWithoutFlag++pprIllegalFamilyInstance :: IllegalFamilyInstanceReason -> SDoc+pprIllegalFamilyInstance = \case+  InvalidAssoc reason -> pprInvalidAssoc reason+  NotAFamilyTyCon ty_or_data tc ->+    vcat [ text "Illegal family instance for" <+> quotes (ppr tc)+         , nest 2 $ parens (quotes (ppr tc) <+> text "is not a" <+> what) ]+    where+      what = ppr ty_or_data <+> text "family"+  NotAnOpenFamilyTyCon tc ->+    text "Illegal instance for closed family" <+> quotes (ppr tc)+  FamilyCategoryMismatch tc ->+    text "Wrong category of family instance; declaration was for a" <+> what <> dot+    where+      what = case tyConFlavour tc of+        OpenFamilyFlavour IAmData _ -> text "data family"+        _                           -> text "type family"+  FamilyArityMismatch _ max_args ->+    text "Number of parameters must match family declaration; expected"+    <+> ppr max_args <> dot+  TyFamNameMismatch fam_tc_name eqn_tc_name ->+    hang (text "Mismatched type name in type family instance.")+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name+               , text "  Actual:" <+> ppr eqn_tc_name ])+  FamInstRHSOutOfScopeTyVars mb_dodgy 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) (map nameUnique tvs)) $+          hang (text "The real LHS (expanding synonyms) is:")+             2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))+  FamInstLHSUnusedBoundTyVars tvs ->+    hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs+          <+> isOrAre tvs <+> text "bound by a forall,")+       2 (text "but not used in the family instance.")++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 ->+    pprWithExplicitKindsWhen (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 pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $+         hang main_msg+            2 (vcat [ppr_eqn, suggestion])+    where+      ppr_eqn :: SDoc+      ppr_eqn =+        quotes (text "type" <+> ppr (mkTyConApp fam_tc pat_tys)+                <+> equals <+> text "...")++      suggestion :: SDoc+      suggestion = text "The arguments to" <+> quotes (ppr fam_tc)+               <+> text "must all be distinct type variables."++invalidAssocHints :: InvalidAssoc -> [GhcHint]+invalidAssocHints = \case+  InvalidAssocInstance rea -> invalidAssocInstanceHints rea+  InvalidAssocDefault  rea -> invalidAssocDefaultHints  rea++invalidAssocInstanceHints :: InvalidAssocInstance -> [GhcHint]+invalidAssocInstanceHints = \case+  AssocInstanceMissing {} -> noHints+  AssocInstanceNotInAClass {} -> noHints+  AssocNotInThisClass {} -> noHints+  AssocNoClassTyVar {} -> noHints+  AssocTyVarsDontMatch {} -> noHints++invalidAssocDefaultHints :: InvalidAssocDefault -> [GhcHint]+invalidAssocDefaultHints = \case+  AssocDefaultNotAssoc {} -> noHints+  AssocMultipleDefaults {} -> noHints+  AssocDefaultBadArgs _ _ bad ->+    assocDefaultBadArgHints bad++assocDefaultBadArgHints :: AssocDefaultBadArgs -> [GhcHint]+assocDefaultBadArgHints = \case+  AssocDefaultNonTyVarArg {} -> noHints+  AssocDefaultDuplicateTyVars {} -> noHints++invalidAssocReason :: InvalidAssoc -> DiagnosticReason+invalidAssocReason = \case+  InvalidAssocInstance rea -> invalidAssocInstanceReason rea+  InvalidAssocDefault  rea -> invalidAssocDefaultReason  rea++invalidAssocInstanceReason :: InvalidAssocInstance -> DiagnosticReason+invalidAssocInstanceReason = \case+  AssocInstanceMissing {} -> WarningWithFlag (Opt_WarnMissingMethods)+  AssocInstanceNotInAClass {} -> ErrorWithoutFlag+  AssocNotInThisClass {} -> ErrorWithoutFlag+  AssocNoClassTyVar {} -> ErrorWithoutFlag+  AssocTyVarsDontMatch {} -> ErrorWithoutFlag++invalidAssocDefaultReason :: InvalidAssocDefault -> DiagnosticReason+invalidAssocDefaultReason = \case+  AssocDefaultNotAssoc {} -> ErrorWithoutFlag+  AssocMultipleDefaults {} -> ErrorWithoutFlag+  AssocDefaultBadArgs _ _ rea ->+    assocDefaultBadArgReason rea++assocDefaultBadArgReason :: AssocDefaultBadArgs -> DiagnosticReason+assocDefaultBadArgReason = \case+  AssocDefaultNonTyVarArg {} -> ErrorWithoutFlag+  AssocDefaultDuplicateTyVars {} -> ErrorWithoutFlag++--------------------------------------------------------------------------------+-- Template Haskell quotes and splices++pprTHError :: THError -> DecoratedSDoc+pprTHError = \case+  THSyntaxError err -> pprTHSyntaxError err+  THNameError   err -> pprTHNameError   err+  THReifyError  err -> pprTHReifyError  err+  TypedTHError  err -> pprTypedTHError  err+  THSpliceFailed rea -> pprSpliceFailReason rea+  AddTopDeclsError err -> pprAddTopDeclsError err++  IllegalStaticFormInSplice e ->+    mkSimpleDecorated $+      sep [ text "static forms cannot be used in splices:"+          , nest 2 $ ppr e+          ]++  FailedToLookupThInstName th_type reason ->+    mkSimpleDecorated $+    case reason of+      NoMatchesFound ->+        text "Couldn't find any instances of"+          <+> text (TH.pprint th_type)+          <+> text "to add documentation to"+      CouldNotDetermineInstance ->+        text "Couldn't work out what instance"+          <+> text (TH.pprint th_type)+          <+> text "is supposed to be"++  AddInvalidCorePlugin plugin ->+    mkSimpleDecorated $+      hang (text "addCorePlugin: invalid plugin module" <+> quotes (text plugin) )+         2 (text "Plugins in the current package can't be specified.")++  AddDocToNonLocalDefn doc_loc ->+    mkSimpleDecorated $+      text "Can't add documentation to" <+> ppr_loc doc_loc <> comma <+>+      text "as it isn't inside the current module."+      where+        ppr_loc (TH.DeclDoc n) = text $ TH.pprint n+        ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n+        ppr_loc (TH.InstDoc t) = text $ TH.pprint t+        ppr_loc TH.ModuleDoc = text "the module header"++  ReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg++pprTHSyntaxError :: THSyntaxError -> DecoratedSDoc+pprTHSyntaxError = mkSimpleDecorated . \case+  IllegalTHQuotes expr ->+    text "Syntax error on" <+> ppr expr+      -- The error message context will say+      -- "In the Template Haskell quotation", so no need to repeat that here.+  BadImplicitSplice ->+    sep [ text "Parse error: module header, import declaration"+        , text "or top-level declaration expected." ]+    -- The compiler should not mention TemplateHaskell, as the common case+    -- is that this is a simple beginner error, for example:+    --+    -- module M where+    --   f :: Int -> Int; f x = x+    --   xyzzy+    --   g y = f y + 1+    --+    -- It's unlikely that 'xyzzy' above was intended to be a Template Haskell+    -- splice; instead it's probably something mistakenly left in the code.+    -- See #12146 for discussion.++  IllegalTHSplice ->+    text "Unexpected top-level splice."+  MismatchedSpliceType splice_type inner_splice_or_bracket ->+    inner <+> text "may not appear in" <+> outer <> dot+      where+        (inner, outer) = case inner_splice_or_bracket of+          IsSplice -> case splice_type of+            Typed   -> (text "Typed splices"  , text "untyped brackets")+            Untyped -> (text "Untyped splices", text "typed brackets")+          IsBracket ->+            case splice_type of+            Typed   -> (text "Untyped brackets", text "typed splices")+            Untyped -> (text "Typed brackets"  , text "untyped splices")+  NestedTHBrackets ->+    text "Template Haskell brackets cannot be nested" <+>+    text "(without intervening splices)"++pprTHNameError :: THNameError -> DecoratedSDoc+pprTHNameError = \case+  NonExactName name ->+    mkSimpleDecorated $+      hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")+         2 (text "Probable cause: you used mkName instead of newName to generate a binding.")+  QuotedNameWrongStage quote ->+    mkSimpleDecorated $+      sep [ text "Stage error: the non-top-level quoted name" <+> ppr quote+          , text "must be used at the same stage at which it is bound." ]++pprTHReifyError :: THReifyError -> DecoratedSDoc+pprTHReifyError = \case+  CannotReifyInstance ty+    -> mkSimpleDecorated $+       hang (text "reifyInstances:" <+> quotes (ppr ty))+          2 (text "is not a class constraint or type family application")+  CannotReifyOutOfScopeThing th_name+    -> mkSimpleDecorated $+       quotes (text (TH.pprint th_name)) <+>+               text "is not in scope at a reify"+             -- Ugh! Rather an indirect way to display the name+  CannotReifyThingNotInTypeEnv name+    -> mkSimpleDecorated $+       quotes (ppr name) <+> text "is not in the type environment at a reify"+  NoRolesAssociatedWithThing thing+    -> mkSimpleDecorated $+       text "No roles associated with" <+> (ppr thing)+  CannotRepresentType sort ty+    -> mkSimpleDecorated $+       hsep [text "Can't represent" <+> sort_doc <+>+             text "in Template Haskell:",+               nest 2 (ppr ty)]+     where+       sort_doc = text $+         case sort of+           LinearInvisibleArgument -> "linear invisible argument"+           CoercionsInTypes -> "coercions in types"++pprTypedTHError :: TypedTHError -> DecoratedSDoc+pprTypedTHError = \case+  SplicePolymorphicLocalVar ident+    -> mkSimpleDecorated $+         text "Can't splice the polymorphic local variable" <+> quotes (ppr ident)+  TypedTHWithPolyType ty+    -> mkSimpleDecorated $+      vcat [ text "Illegal polytype:" <+> ppr ty+           , text "The type of a Typed Template Haskell expression must" <+>+             text "not have any quantification." ]++pprSpliceFailReason :: SpliceFailReason -> DecoratedSDoc+pprSpliceFailReason = \case+  SpliceThrewException phase _exn exn_msg expr show_code ->+    mkSimpleDecorated $+      vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:"+           , nest 2 (text exn_msg)+           , if show_code then text "Code:" <+> ppr expr else empty]+    where phaseStr =+            case phase of+              SplicePhase_Run -> "run"+              SplicePhase_CompileAndLink -> "compile and link"+  RunSpliceFailure err -> pprRunSpliceFailure Nothing err++pprAddTopDeclsError :: AddTopDeclsError -> DecoratedSDoc+pprAddTopDeclsError = \case+  InvalidTopDecl _decl ->+    mkSimpleDecorated $+      sep [ text "Only function, value, annotation, and foreign import declarations"+          , text "may be added with" <+> quotes (text "addTopDecls") <> dot ]+  AddTopDeclsUnexpectedDeclarationSplice {} ->+    mkSimpleDecorated $+      text "Declaration splices are not permitted" <+>+      text "inside top-level declarations added with" <+>+      quotes (text "addTopDecls") <> dot+  AddTopDeclsRunSpliceFailure err ->+    pprRunSpliceFailure (Just "addTopDecls") err++pprRunSpliceFailure :: Maybe String -> RunSpliceFailReason -> DecoratedSDoc+pprRunSpliceFailure mb_calling_fn (ConversionFail what reason) =+  mkSimpleDecorated . add_calling_fn . addSpliceInfo $+    pprConversionFailReason reason+  where+    add_calling_fn rest =+      case mb_calling_fn of+        Just calling_fn ->+          hang (text "Error in a declaration passed to" <+> quotes (text calling_fn) <> colon)+             2 rest+        Nothing -> rest+    addSpliceInfo = case what of+      ConvDec  d -> addSliceInfo' "declaration" d+      ConvExp  e -> addSliceInfo' "expression" e+      ConvPat  p -> addSliceInfo' "pattern" p+      ConvType t -> addSliceInfo' "type" t+    addSliceInfo' what item reasonErr = reasonErr $$ descr+      where+            -- Show the item in pretty syntax normally,+            -- but with all its constructors if you say -dppr-debug+        descr = hang (text "When splicing a TH" <+> text what <> colon)+                   2 (getPprDebug $ \case+                       True  -> text (show item)+                       False -> text (TH.pprint item))++thErrorReason :: THError -> DiagnosticReason+thErrorReason = \case+  THSyntaxError err -> thSyntaxErrorReason err+  THNameError   err -> thNameErrorReason   err+  THReifyError  err -> thReifyErrorReason  err+  TypedTHError  err -> typedTHErrorReason  err+  THSpliceFailed rea -> spliceFailedReason rea+  AddTopDeclsError err -> addTopDeclsErrorReason err++  IllegalStaticFormInSplice {} -> ErrorWithoutFlag+  FailedToLookupThInstName {}  -> ErrorWithoutFlag+  AddInvalidCorePlugin {}      -> ErrorWithoutFlag+  AddDocToNonLocalDefn {}      -> ErrorWithoutFlag+  ReportCustomQuasiError is_error _ ->+    if is_error+    then ErrorWithoutFlag+    else WarningWithoutFlag++thSyntaxErrorReason :: THSyntaxError -> DiagnosticReason+thSyntaxErrorReason = \case+  IllegalTHQuotes{}      -> ErrorWithoutFlag+  BadImplicitSplice      -> ErrorWithoutFlag+  IllegalTHSplice{}      -> ErrorWithoutFlag+  NestedTHBrackets{}     -> ErrorWithoutFlag+  MismatchedSpliceType{} -> ErrorWithoutFlag++thNameErrorReason :: THNameError -> DiagnosticReason+thNameErrorReason = \case+  NonExactName {}         -> ErrorWithoutFlag+  QuotedNameWrongStage {} -> ErrorWithoutFlag++thReifyErrorReason :: THReifyError -> DiagnosticReason+thReifyErrorReason = \case+  CannotReifyInstance {}          -> ErrorWithoutFlag+  CannotReifyOutOfScopeThing {}   -> ErrorWithoutFlag+  CannotReifyThingNotInTypeEnv {} -> ErrorWithoutFlag+  NoRolesAssociatedWithThing {}   -> ErrorWithoutFlag+  CannotRepresentType {}          -> ErrorWithoutFlag++typedTHErrorReason :: TypedTHError -> DiagnosticReason+typedTHErrorReason = \case+  SplicePolymorphicLocalVar {} -> ErrorWithoutFlag+  TypedTHWithPolyType {}       -> ErrorWithoutFlag++spliceFailedReason :: SpliceFailReason -> DiagnosticReason+spliceFailedReason = \case+  SpliceThrewException {} -> ErrorWithoutFlag+  RunSpliceFailure {}     -> ErrorWithoutFlag++addTopDeclsErrorReason :: AddTopDeclsError -> DiagnosticReason+addTopDeclsErrorReason = \case+  InvalidTopDecl {}+    -> ErrorWithoutFlag+  AddTopDeclsUnexpectedDeclarationSplice {}+    -> ErrorWithoutFlag+  AddTopDeclsRunSpliceFailure {}+    -> ErrorWithoutFlag++thErrorHints :: THError -> [GhcHint]+thErrorHints = \case+  THSyntaxError err -> thSyntaxErrorHints err+  THNameError   err -> thNameErrorHints   err+  THReifyError  err -> thReifyErrorHints  err+  TypedTHError  err -> typedTHErrorHints  err+  THSpliceFailed rea -> spliceFailedHints rea+  AddTopDeclsError err -> addTopDeclsErrorHints err++  IllegalStaticFormInSplice {} -> noHints+  FailedToLookupThInstName {}  -> noHints+  AddInvalidCorePlugin {}      -> noHints+  AddDocToNonLocalDefn {}      -> noHints+  ReportCustomQuasiError {}    -> noHints++thSyntaxErrorHints :: THSyntaxError -> [GhcHint]+thSyntaxErrorHints = \case+  IllegalTHQuotes{}+    -> [suggestAnyExtension [LangExt.TemplateHaskell, LangExt.TemplateHaskellQuotes]]+  BadImplicitSplice {}+    -> noHints -- NB: don't suggest TemplateHaskell+               -- see comments on BadImplicitSplice in pprTHSyntaxError+  IllegalTHSplice{}+    -> [suggestExtension LangExt.TemplateHaskell]+  NestedTHBrackets{}+    -> noHints+  MismatchedSpliceType{}+    -> noHints++thNameErrorHints :: THNameError -> [GhcHint]+thNameErrorHints = \case+  NonExactName {}         -> noHints+  QuotedNameWrongStage {} -> noHints++thReifyErrorHints :: THReifyError -> [GhcHint]+thReifyErrorHints = \case+  CannotReifyInstance {}          -> noHints+  CannotReifyOutOfScopeThing {}   -> noHints+  CannotReifyThingNotInTypeEnv {} -> noHints+  NoRolesAssociatedWithThing {}   -> noHints+  CannotRepresentType {}          -> noHints++typedTHErrorHints :: TypedTHError -> [GhcHint]+typedTHErrorHints = \case+  SplicePolymorphicLocalVar {} -> noHints+  TypedTHWithPolyType {}       -> noHints++spliceFailedHints :: SpliceFailReason -> [GhcHint]+spliceFailedHints = \case+  SpliceThrewException {} -> noHints+  RunSpliceFailure {}     -> noHints++addTopDeclsErrorHints :: AddTopDeclsError -> [GhcHint]+addTopDeclsErrorHints = \case+  InvalidTopDecl {}+    -> noHints+  AddTopDeclsUnexpectedDeclarationSplice {}+    -> noHints+  AddTopDeclsRunSpliceFailure {}+    -> noHints++--------------------------------------------------------------------------------++pprPatersonCondFailure ::+  PatersonCondFailure -> PatersonCondFailureContext -> Type -> Type -> SDoc+pprPatersonCondFailure (PCF_TyVar tvs) InInstanceDecl lhs rhs =+  hang (occMsg tvs)+    2 (sep [ text "in the constraint" <+> quotes (ppr lhs)+         , text "than in the instance head" <+> quotes (ppr rhs) ])+  where+    occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)+                 <+> pp_occurs <+> text "more often"+    pp_occurs | isSingleton tvs = text "occurs"+              | otherwise       = text "occur"+pprPatersonCondFailure (PCF_TyVar tvs) InTyFamEquation lhs rhs =+  hang (occMsg tvs)+    2 (sep [ text "in the type-family application" <+> quotes (ppr rhs)+         , text "than in the LHS of the family instance" <+> quotes (ppr lhs) ])+  where+    occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)+                 <+> pp_occurs <+> text "more often"+    pp_occurs | isSingleton tvs = text "occurs"+              | otherwise       = text "occur"+pprPatersonCondFailure PCF_Size InInstanceDecl lhs rhs =+  hang (text "The constraint" <+> quotes (ppr lhs))+    2 (sep [ text "is no smaller than", pp_rhs ])+  where pp_rhs = text "the instance head" <+> quotes (ppr rhs)+pprPatersonCondFailure PCF_Size InTyFamEquation lhs rhs =+  hang (text "The type-family application" <+> quotes (ppr rhs))+    2 (sep [ text "is no smaller than", pp_lhs ])+  where pp_lhs = text "the LHS of the family instance" <+> quotes (ppr lhs)+pprPatersonCondFailure  (PCF_TyFam tc) InInstanceDecl lhs _rhs =+  hang (text "Illegal use of type family" <+> quotes (ppr tc))+    2 (text "in the constraint" <+> quotes (ppr lhs))+pprPatersonCondFailure  (PCF_TyFam tc) InTyFamEquation _lhs rhs =+  hang (text "Illegal nested use of type family" <+> quotes (ppr tc))+    2 (text "in the arguments of the type-family application" <+> quotes (ppr rhs))++++--------------------------------------------------------------------------------++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++--------------------------------------------------------------------------------
compiler/GHC/Tc/Errors/Types.hs view
@@ -1,4045 +1,6435 @@ {-# 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 #-}++module GHC.Tc.Errors.Types (+  -- * Main types+    TcRnMessage(..)+  , TcRnMessageOpts(..)+  , mkTcRnUnknownMessage+  , TcRnMessageDetailed(..)+  , TypeDataForbids(..)+  , ErrInfo(..)+  , FixedRuntimeRepProvenance(..)+  , pprFixedRuntimeRepProvenance+  , ShadowedNameProvenance(..)+  , 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(..)++  , 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(..)+  , EmptyStatementGroupErrReason(..)+  , UnexpectedStatement(..)+  , DeclSort(..)+  , NonStandardGuards(..)+  , RuleLhsErrReason(..)+  , HsigShapeMismatchReason(..)+  , WrongThingSort(..)+  , StageCheckReason(..)+  , UninferrableTyVarCtx(..)+  , PatSynInvalidRhsReason(..)+  , BadFieldAnnotationReason(..)+  , SuperclassCycle(..)+  , SuperclassCycleDetail(..)+  , RoleValidationFailedReason(..)+  , DisabledClassExtension(..)+  , TyFamsDisabledReason(..)+  , TypeApplication(..)+  , HsTypeOrSigType(..)+  , HsTyVarBndrExistentialFlag(..)+  , TySynCycleTyCons+  , BadImportKind(..)+  , DodgyImportsReason (..)+  , ImportLookupReason (..)+  , UnusedImportReason (..)+  , UnusedImportName (..)+  , NestedForallsContextsIn(..)+  , UnusedNameProv(..)+  , NonCanonicalDefinition(..)+  , NonCanonical_Monoid(..)+  , NonCanonical_Monad(..)++    -- * 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(..)+  , InvalidAssoc(..), InvalidAssocInstance(..)+  , InvalidAssocDefault(..), AssocDefaultBadArgs(..)++    -- * 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(..)+  ) where++import GHC.Prelude++import GHC.Hs+import GHC.Tc.Errors.Types.PromotionErr+import 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(..), InstanceWhat )+import GHC.Tc.Types.Rank (Rank)+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(..))+import GHC.Types.ForeignCall (CLabelString)+import GHC.Types.Id.Info ( RecSelParent(..) )+import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan)+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.Unit.Types (Module)+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)+import GHC.Driver.Backend (Backend)+import GHC.Unit.State (UnitState)+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 qualified Data.List.NonEmpty as NE+import           Data.Typeable (Typeable)+import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt)+import qualified Language.Haskell.TH.Syntax as TH++import GHC.Generics ( Generic )+import GHC.Types.Name.Env (NameEnv)+import GHC.Iface.Errors.Types+import GHC.Unit.Module.ModIface (ModIface)+import GHC.Tc.Types.TH+import GHC.Tc.Types.BasicTypes++++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 :: !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 (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 :: (UnknownDiagnostic (DiagnosticOpts 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+                   -> [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.++  {-| 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+                                     -> !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++  {-| 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+  -}+  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++  {-| 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 :: HsType 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 :: 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++  {-| 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.++      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 :: GlobalRdrElt -> 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 :: !(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++  {-| 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++  {-| TcRnTypeMultipleOccurenceOfBindVar is an error that occurs if a bound+      type variable's name is already in use.+    Example:+      f :: forall a. ...+      f (MkT @a ...) = ...++    Test cases: TyAppPat_ScopedTyVarConflict TyAppPat_NonlinearMultiPat TyAppPat_NonlinearMultiAppPat+  -}+  TcRnBindVarAlreadyInScope :: [LocatedN RdrName] -> TcRnMessage++  {-| TcRnBindMultipleVariables is an error that occurs in the case of+    multiple occurrences of a bound variable.+    Example:+      foo (MkFoo @(a,a) ...) = ...++    Test case: typecheck/should_fail/TyAppPat_NonlinearSinglePat+  -}+  TcRnBindMultipleVariables :: HsDocContext -> LocatedN 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: 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+                 -> [ImportError]    -- ^ import errors that are relevant+                 -> [GhcHint]        -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor+                 -> TcRnMessage++  {-| TcRnTermNameInType is an error that occurs when a term-level identifier+      is used in a type.++      Example:++        import qualified Prelude++        bad :: Prelude.fst (Bool, Float)+        bad = False++      Test cases: T21605{c,d}+  -}+  TcRnTermNameInType :: RdrName -> [GhcHint] -> 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++  {-| 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++  {-| 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 :: Either (HsType GhcPs) (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 (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++  {-| 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++  {-| 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++  {-| 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 occuring 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.++      Examples:++        type Foo = [Nat, Char]++        type Bar = [Int, String]++      Test cases: linear/should_fail/T18888+                  polykinds/T7151+                  th/TH_Promoted1Tuple+                  typecheck/should_fail/tcfail094+  -}+  TcRnDataKindsError :: TypeOrKind -> HsType GhcPs -> 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++  {-| 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 :: Maybe ModuleName+  } -> 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++  {-| 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+    :: 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++  {-| 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(s):++       case () of++     Test cases: rename/should_fail/RnEmptyCaseFail+  -}+  TcRnEmptyCase :: HsMatchContext GhcRn -> 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++  {-| '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++  {-| '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++  {-| TcRnDeprecatedInvisTyArgInConPat is a warning that triggers on type applications+      in constructor patterns when the user has not enabled '-XTypeAbstractions'+      but instead has enabled both '-XScopedTypeVariables' and '-XTypeApplications'.++      This warning is a deprecation mechanism that is scheduled until GHC 9.12.+  -}+  TcRnDeprecatedInvisTyArgInConPat+    :: TcRnMessage++  {-| 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++  {-| 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++  {-| 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 clause without specified deriving strategy.++      Example:++        data T = T+          deriving Eq++      Test cases: rename/should_compile/T15798a+                  rename/should_compile/T15798b+                  rename/should_compile/T15798c+  -}+  TcRnNoDerivStratSpecified+    :: Bool -- True if DerivingStrategies is enabled+    -> 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++  {-| TcRnBadlyStaged is an error that occurs when a TH binding is used in an+    invalid stage.++    Test cases:+      T17820d+  -}+  TcRnBadlyStaged+    :: !StageCheckReason -- ^ The binding being spliced.+    -> !Int -- ^ The binding stage.+    -> !Int -- ^ The stage at which the binding is used.+    -> TcRnMessage++  {-| TcRnStageRestriction is an error that occurs when a top level splice refers to+    a local name.++    Test cases:+      T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}+  -}+  TcRnStageRestriction+    :: !StageCheckReason -- ^ The binding being spliced.+    -> 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 selector+    was not defined for all constructors of a data type.++    Test cases:+      DRFPartialFields, T7169+  -}+  TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector+                           -> 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++  {-| TcRnCompatUnqualifiedImport is a warning indicating that a special+    module (right now only Data.List) was imported unqualified without+    import list, for compatibility reasons.++    Test cases:+      T17244A+  -}+  TcRnCompatUnqualifiedImport :: !(ImportDecl GhcPs) -- ^ The import+                              -> 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 :: !TypeApplication -- ^ what kind of type application is it?+                               -> 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+  -}+  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++  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.++-- | 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++-- | 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 !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+  | InstHeadNonClass+    !(Maybe TyCon) -- ^ the 'TyCon' at the head of the instance head,+                   -- or 'Nothing' if the instance head is not even headed+                   -- by a 'TyCon'++  -- | 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+++-- | 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+      ![Name] -- ^ the out-of-scope type variables++  | FamInstLHSUnusedBoundTyVars+      ![Name] -- ^ the unused bound type variables++  | InvalidAssoc !InvalidAssoc+  deriving Generic++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.+    --+    -- 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 :: [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 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]++  -- | An equality between two types is blocked on a kind equality+  -- between their kinds.+  --+  -- Test cases: none.+  | BlockedEquality ErrorItem+    -- These are for the "blocked" equalities, as described in+    -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality,+    -- wrinkle (EIK2). There should always be another unsolved wanted around,+    -- which will ordinarily suppress this message. But this can still be printed out+    -- with -fdefer-type-errors (sigh), so we must produce a message.++  -- | Something was not applied to sufficiently many arguments.+  --+  --  Example:+  --+  --    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++data BadImportKind+  -- | Module does not export...+  = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant+  -- | Missing @type@ keyword when importing a 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 [OccName]+  -- | Incorrect @type@ keyword when importing something which isn't a type.+  | BadImportAvailVar+  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++  -- | 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 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++  -- | A name is not in scope during type checking but passed the renamer.+  --+  -- Test cases:+  --   none+  | NotInScopeTc (NameEnv TcTyThing)+  deriving Generic++-- | Create a @"not in scope"@ error message for the given 'RdrName'.+mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage+mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints++-- | Configuration for pretty-printing valid hole fits.+data HoleFitDispConfig =+  HFDC { showWrap, showWrapVars, showType, showProv, showMatches+          :: 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)"+++-- | 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 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 StageCheckReason+  = StageCheckInstance !InstanceWhat !PredType+  | StageCheckSplice !Name++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 was applied to an abstract type in an indefinite package+    in Backpack.++    Test cases:+    unpack_sums_5, T3966, T7050+  -}+  BackpackUnpackAbstractType :: 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)++data TypeApplication+  = TypeApplication !(HsType GhcPs) !TypeOrKind+  | TypeApplicationInPattern !(HsConPatTyArg GhcPs)+  deriving Generic++-- | 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)++-- | 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+                  -> Bool -- ^ whether @-XPatternSynonyms@ was enabled+                  -> 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++  {-| QuotedNameWrongStage is an error that can happen when a+      (non-top-level) Name is used at a different Template Haskell stage+      than the stage at which it is bound.++     Test cases: T16976z+  -}+  | QuotedNameWrongStage !(HsQuote GhcPs)+  deriving Generic++data THReifyError+  = {-| 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+  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++-- 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
+ compiler/GHC/Tc/Errors/Types/PromotionErr.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveGeneric #-}+module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..)+                                        , pprPECategory+                                        , peCategory+                                        ) where++import GHC.Prelude+import GHC.Core.Type (ThetaType)+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Generics (Generic)++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 [Promoted variables in types]+  | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)+  | 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 NoDataKindsDC        = text "NoDataKindsDC"+  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 NoDataKindsDC        = "data constructor"+peCategory TermVariablePE       = "term variable"+peCategory TypeVariablePE       = "type variable"+++{- 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
@@ -8,7 +8,8 @@     -- * The work list     WorkList(..), isEmptyWorkList, emptyWorkList,     extendWorkListNonEq, extendWorkListCt,-    extendWorkListCts, extendWorkListEq,+    extendWorkListCts, extendWorkListCtList,+    extendWorkListEq, extendWorkListEqs,     appendWorkList, extendWorkListImplic,     workListSize,     selectWorkItem,@@ -16,28 +17,39 @@     -- * The inert set     InertSet(..),     InertCans(..),-    InertEqs,     emptyInert,-    addInertItem,      noMatchableGivenDicts,-    noGivenNewtypeReprEqs,+    noGivenNewtypeReprEqs, updGivenEqs,     mightEqualLater,     prohibitedSuperClassSolve,      -- * Inert equalities+    InertEqs,     foldTyEqs, delEq, findEq,     partitionInertEqs, partitionFunEqs,+    foldFunEqs, addEqToCans, +    -- * Inert Dicts+    updDicts, delDict, addDict, filterDicts, partitionDicts,+    addSolvedDict,++    -- * Inert Irreds+    InertIrreds, delIrred, addIrreds, addIrred, foldIrreds,+    findMatchingIrreds, updIrreds, addIrredToCans,+     -- * Kick-out-    kickOutRewritableLHS,+    KickOutSpec(..), kickOutRewritableLHS,      -- * Cycle breaker vars     CycleBreakerVarStack,     pushCycleBreakerVarStack,-    insertCycleBreakerBinding,-    forAllCycleBreakerBindings_+    addCycleBreakerBindings,+    forAllCycleBreakerBindings_, +    -- * Solving one from another+    InteractResult(..), solveOneFromTheOther+   ) where  import GHC.Prelude@@ -49,6 +61,8 @@  import GHC.Types.Var import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Basic( SwapFlag(..) )  import GHC.Core.Reduction import GHC.Core.Predicate@@ -56,18 +70,20 @@ import qualified GHC.Core.TyCo.Rep as Rep import GHC.Core.Class( Class ) import GHC.Core.TyCon+import GHC.Core.Class( classTyCon ) import GHC.Core.Unify -import GHC.Data.Bag import GHC.Utils.Misc       ( partitionWith ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Data.Maybe+import GHC.Data.Bag -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 Data.Function ( on )+ import Control.Monad      ( forM_ )  {-@@ -93,7 +109,7 @@  Note [Prioritise equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to process equalities /first/:+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@@ -111,14 +127,17 @@   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]+  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+  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. +Among the equalities we prioritise ones with an empty rewriter set;+see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint, wrinkle (W1).++ Note [Prioritise class equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We prioritise equalities in the solver (see selectWorkItem). But class@@ -157,6 +176,13 @@                        -- See Note [Prioritise equalities]                        -- See Note [Prioritise class equalities] +       , wl_rw_eqs  :: [Ct]  -- Like wl_eqs, but ones that have a non-empty+                             -- rewriter set; or, more precisely, did when+                             -- added to the WorkList+         -- We prioritise wl_eqs over wl_rw_eqs;+         -- see Note [Prioritise Wanteds with empty RewriterSet]+         -- in GHC.Tc.Types.Constraint for more details.+        , wl_rest    :: [Ct]         , wl_implics :: Bag Implication  -- See Note [Residual implications]@@ -164,21 +190,42 @@  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, wl_rw_eqs = rw_eqs1+        , wl_rest = rest1, wl_implics = implics1 })+    (WL { wl_eqs = eqs2, wl_rw_eqs = rw_eqs2+        , wl_rest = rest2, wl_implics = implics2 })    = WL { wl_eqs     = eqs1     ++ eqs2+        , wl_rw_eqs  = rw_eqs1  ++ rw_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+workListSize (WL { wl_eqs = eqs, wl_rw_eqs = rw_eqs, wl_rest = rest })+  = length eqs + length rw_eqs + length rest -extendWorkListEq :: Ct -> WorkList -> WorkList-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }+extendWorkListEq :: RewriterSet -> Ct -> WorkList -> WorkList+extendWorkListEq rewriters ct wl+  | isEmptyRewriterSet rewriters      -- A wanted that has not been rewritten+    -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]+    --                         in GHC.Tc.Types.Constraint+  = wl { wl_eqs = ct : wl_eqs wl }+  | otherwise+  = wl { wl_rw_eqs = ct : wl_rw_eqs wl } +extendWorkListEqs :: RewriterSet -> Bag Ct -> WorkList -> WorkList+-- Add [eq1,...,eqn] to the work-list+-- They all have the same rewriter set+-- The constraints will be solved in left-to-right order:+--   see Note [Work-list ordering] in GHC.Tc.Solved.Equality+extendWorkListEqs rewriters eqs wl+  | isEmptyRewriterSet rewriters+    -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]+    --                         in GHC.Tc.Types.Constraint+  = wl { wl_eqs = foldr (:) (wl_eqs wl) eqs }+         -- The foldr just appends wl_eqs to the bag of eqs+  | otherwise+  = wl { wl_rw_eqs = foldr (:) (wl_rw_eqs wl) eqs }+ extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }@@ -187,20 +234,25 @@ extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }  extendWorkListCt :: Ct -> WorkList -> WorkList--- Agnostic+-- Agnostic about what kind of constraint extendWorkListCt ct wl- = case classifyPredType (ctPred ct) of+ = case classifyPredType (ctEvPred ev) of      EqPred {}-       -> extendWorkListEq ct wl+       -> extendWorkListEq rewriters ct wl       ClassPred cls _  -- See Note [Prioritise class equalities]-       |  isEqPredClass cls-       -> extendWorkListEq ct wl+       |  isEqualityClass cls+       -> extendWorkListEq rewriters ct wl       _ -> extendWorkListNonEq ct wl+  where+    ev = ctEvidence ct+    rewriters = ctEvRewriters ev -extendWorkListCts :: [Ct] -> WorkList -> WorkList--- Agnostic+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@@ -208,21 +260,24 @@   = null eqs && null rest && isEmptyBag implics  emptyWorkList :: WorkList-emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }+emptyWorkList = WL { wl_eqs  = [], wl_rw_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+selectWorkItem wl@(WL { wl_eqs = eqs, wl_rw_eqs = rw_eqs, wl_rest = rest })+  | ct:cts <- eqs    = Just (ct, wl { wl_eqs    = cts })+  | ct:cts <- rw_eqs = Just (ct, wl { wl_rw_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 })+  ppr (WL { wl_eqs = eqs, wl_rw_eqs = rw_eqs, wl_rest = rest, wl_implics = implics })    = text "WL" <+> (braces $      vcat [ ppUnless (null eqs) $             text "Eqs =" <+> vcat (map ppr eqs)+          , ppUnless (null rw_eqs) $+            text "RwEqs =" <+> vcat (map ppr rw_eqs)           , ppUnless (null rest) $             text "Non-eqs =" <+> vcat (map ppr rest)           , ppUnless (isEmptyBag implics) $@@ -237,13 +292,15 @@ *                                                                      * ********************************************************************* -} -type CycleBreakerVarStack = NonEmpty [(TcTyVar, TcType)]+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.Canonical+   -- 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@@ -262,8 +319,9 @@               -- (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+       , 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]        }@@ -279,19 +337,19 @@  emptyInertCans :: InertCans emptyInertCans-  = IC { inert_eqs          = emptyDVarEnv+  = IC { inert_eqs          = emptyTyEqs+       , inert_funeqs       = emptyFunEqs        , inert_given_eq_lvl = topTcLevel        , inert_given_eqs    = False        , inert_dicts        = emptyDictMap        , inert_safehask     = emptyDictMap-       , inert_funeqs       = emptyFunEqs        , inert_insts        = []-       , inert_irreds       = emptyCts }+       , inert_irreds       = emptyBag }  emptyInert :: InertSet emptyInert   = IS { inert_cans           = emptyInertCans-       , inert_cycle_breakers = [] :| []+       , inert_cycle_breakers = emptyBag :| []        , inert_famapp_cache   = emptyFunEqs        , inert_solved_dicts   = emptyDictMap } @@ -362,7 +420,7 @@     conditional on the kind of instance    - It is only called when applying an instance decl,-    in GHC.Tc.Solver.Interact.doTopReactDict+    in GHC.Tc.Solver.Dict.tryInstances    - ClsInst.InstanceWhat says what kind of instance was     used to solve the constraint.  In particular@@ -543,7 +601,7 @@      -- (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.+inert set, in updGivenEqs.  Then a unification variable alpha[n] is untouchable iff     n < inert_given_eq_lvl@@ -569,7 +627,7 @@    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+   Because beta might turn into an equality, updGivenEqs 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?@@ -579,7 +637,7 @@    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.+   Hence the 'mentionsOuterVar' test in updGivenEqs.     However, solely to support better error messages    (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track@@ -722,7 +780,7 @@  ----------------------------------------------------------------------------- Our main invariant:-   the CEqCans in inert_eqs should be a terminating generalised substitution+   the EqCts in inert_eqs should be a terminating generalised substitution -----------------------------------------------------------------------------  Note that termination is not the same as idempotence.  To apply S to a@@ -769,7 +827,7 @@ 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+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: @@ -814,7 +872,7 @@       (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.+          -- Note [EqCt occurs check] in GHC.Tc.Types.Constraint.        AND, for every (lhs1 -fs-> s) in S:            (K0) not (fw >= fs)@@ -849,7 +907,7 @@  * 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.+  (TyEq:OC) of CEqCan. See also Note [EqCt 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@@ -1073,23 +1131,23 @@ 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+              -- All EqCt 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.+       , 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 Ct+       , inert_dicts :: DictMap DictCt               -- Dictionaries only               -- All fully rewritten (modulo flavour constraints)               --     wrt inert_eqs         , inert_insts :: [QCInst] -       , inert_safehask :: DictMap Ct+       , 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@@ -1098,7 +1156,7 @@               -- ^ See Note [Safe Haskell Overlapping Instances Implementation]               -- in GHC.Tc.Solver -       , inert_irreds :: Cts+       , 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])@@ -1118,6 +1176,8 @@        }  type InertEqs    = DTyVarEnv EqualCtList+type InertFunEqs = FunEqMap  EqualCtList+type InertIrreds = Bag IrredCt  instance Outputable InertCans where   ppr (IC { inert_eqs = eqs@@ -1131,67 +1191,69 @@      = braces $ vcat       [ ppUnless (isEmptyDVarEnv eqs) $-        text "Equalities:"-          <+> pprCts (foldDVarEnv folder emptyCts eqs)+        text "Equalities ="+          <+> pprBag (foldTyEqs consBag eqs emptyBag)       , ppUnless (isEmptyTcAppMap funeqs) $-        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)+        text "Type-function equalities ="+          <+> pprBag (foldFunEqs consBag funeqs emptyBag)       , ppUnless (isEmptyTcAppMap dicts) $-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)+        text "Dictionaries =" <+> pprBag (dictsToBag dicts)       , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)-      , ppUnless (isEmptyCts irreds) $-        text "Irreds =" <+> pprCts irreds+        text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask)+      , 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       ]-    where-      folder eqs rest = listToBag eqs `andCts` rest + {- ********************************************************************* *                                                                      *                    Inert equalities *                                                                      * ********************************************************************* -} -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs+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 -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 :: (EqCt -> b -> b) -> InertEqs -> b -> b foldTyEqs k eqs z   = foldDVarEnv (\cts z -> foldr k z cts) z eqs -findTyEqs :: InertCans -> TyVar -> [Ct]+findTyEqs :: InertCans -> TyVar -> [EqCt] findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv) -delEq :: InertCans -> CanEqLHS -> TcType -> InertCans-delEq ic lhs rhs = case lhs of+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 :: Ct -> Bool-    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1-    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)+    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 -> [Ct]+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)@@ -1200,81 +1262,176 @@ partition_eqs_container   :: forall container    . container    -- empty container-  -> (forall b. (EqualCtList -> b -> b) -> b -> container -> b) -- folder-  -> (container -> CanEqLHS -> EqualCtList -> container)  -- extender-  -> (Ct -> Bool)+  -> (forall b. (EqCt -> b -> b) ->  container -> b -> b) -- folder+  -> (EqCt -> container -> container)  -- extender+  -> (EqCt -> Bool)   -> container-  -> ([Ct], container)+  -> ([EqCt], container) partition_eqs_container empty_container fold_container extend_container pred orig_inerts-  = fold_container folder ([], empty_container) orig_inerts+  = fold_container folder orig_inerts ([], empty_container)   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+    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 :: (Ct -> Bool)   -- Ct will always be a CEqCan with a TyVarLHS+partitionInertEqs :: (EqCt -> Bool)   -- EqCt will always have a TyVarLHS                   -> InertEqs-                  -> ([Ct], InertEqs)-partitionInertEqs = partition_eqs_container emptyDVarEnv foldDVarEnv extendInertEqs+                  -> ([EqCt], InertEqs)+partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs addInertEqs --- 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)+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) -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)+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)+++ {- ********************************************************************* *                                                                      *-                Adding to and removing from the inert set+                   Inert Dicts *                                                                      *+********************************************************************* -}++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+*                                                                      * ********************************************************************* -} -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 }+addIrredToCans :: TcLevel -> IrredCt -> InertCans -> InertCans+addIrredToCans tc_lvl irred ics+  = updGivenEqs tc_lvl (CIrredCan irred) $+    updIrreds (addIrred irred) ics -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 }+addIrreds :: [IrredCt] -> InertIrreds -> InertIrreds+addIrreds extras irreds+  | null extras = irreds+  | otherwise   = irreds `unionBags` listToBag extras -addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item }+addIrred :: IrredCt -> InertIrreds -> InertIrreds+addIrred extra irreds = irreds `snocBag` extra -addInertItem _ _ item-  = pprPanic "upd_inert set: can't happen! Inserting " $-    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds+updIrreds :: (InertIrreds -> InertIrreds) -> InertCans -> InertCans+updIrreds upd ics = ics { inert_irreds = upd (inert_irreds ics) } -updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans+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 `tcEqTypeNoKindCheck` 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 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2+      = Just NotSwapped+      | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` 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]-updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })+updGivenEqs 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'@@ -1292,17 +1449,31 @@     --          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+    not_equality (CEqCan (EqCt { eq_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)+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++{- 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+-}++kickOutRewritableLHS :: KickOutSpec -> CtFlavourRole -> InertCans -> (Cts, InertCans) -- See Note [kickOutRewritable]-kickOutRewritableLHS new_fr new_lhs+kickOutRewritableLHS ko_spec new_fr@(_, new_role)                      ics@(IC { inert_eqs      = tv_eqs                              , inert_dicts    = dictmap                              , inert_funeqs   = funeqmap@@ -1317,28 +1488,22 @@                         , 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)+    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_ct dictmap-    (irs_out,    irs_in)    = partitionBag      kick_out_ct irreds+    (dicts_out,  dicts_in)  = partitionDicts    (kick_out_ct . CDictCan) dictmap+    (irs_out,    irs_in)    = partitionBag      (kick_out_ct . CIrredCan) 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+    -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve     insts_out :: [Ct]     insts_in  :: [QCInst]     (insts_out, insts_in)@@ -1353,14 +1518,12 @@       | 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+    fr_tv_can_rewrite_ty :: (TyVar -> Bool) -> EqRel -> Type -> Bool+    fr_tv_can_rewrite_ty ok_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+        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && ok_tv tv      fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool     fr_tf_can_rewrite_ty new_tf new_tf_args role ty@@ -1373,33 +1536,28 @@               -- 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+    {-# INLINE fr_can_rewrite_ty #-}   -- Perform case analysis on ko_spec 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_can_rewrite_ty = case ko_spec of  -- See Note [KickOutSpec]+      KOAfterUnify tvs                    -> fr_tv_can_rewrite_ty (`elemVarSet` tvs)+      KOAfterAdding (TyVarLHS tv)         -> fr_tv_can_rewrite_ty (== tv)+      KOAfterAdding (TyFamLHS tf tf_args) -> fr_tf_can_rewrite_ty tf 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)+    kick_out_ct ct = fr_may_rewrite fs && fr_can_rewrite_ty role (ctPred ct)+      where+        fs@(_,role) = ctFlavourRole 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 })+    kick_out_eq :: EqCt -> Bool+    kick_out_eq (EqCt { eq_lhs = lhs, eq_rhs = rhs_ty+                      , eq_ev = ev, eq_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 @@ -1427,14 +1585,31 @@          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)+              NomEq  -> is_new_lhs      rhs_ty   -- (K3a)+              ReprEq -> head_is_new_lhs rhs_ty   -- (K3b) -    kick_out_eq ct = pprPanic "kick_out_eq" (ppr ct)+    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_can_eq_lhs_head (TyVarLHS tv) = go+    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')   = tv == tv'+        go (Rep.TyVarTy tv)    = is_tv tv         go (Rep.AppTy fun _)   = go fun         go (Rep.CastTy ty _)   = go ty         go (Rep.TyConApp {})   = False@@ -1442,7 +1617,9 @@         go (Rep.ForAllTy {})   = False         go (Rep.FunTy {})      = False         go (Rep.CoercionTy {}) = False-    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go++    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@@ -1507,9 +1684,9 @@  * 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.+ * We rewrite those insolubles in GHC.Tc.Solver.Equality    See Note [Make sure that insolubles are fully rewritten]-   in GHC.Tc.Solver.Canonical.+   in GHC.Tc.Solver.Equality -}  {- *********************************************************************@@ -1539,13 +1716,13 @@  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+-- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Equality --     This is the only call site. noGivenNewtypeReprEqs tc inerts   = not (anyBag might_help (inert_irreds (inert_cans inerts)))   where-    might_help ct-      = case classifyPredType (ctPred ct) of+    might_help irred+      = case classifyPredType (ctEvPred (irredCtEvidence irred)) of           EqPred ReprEq t1 t2              | Just (tc1,_) <- tcSplitTyConApp_maybe t1              , tc == tc1@@ -1557,7 +1734,7 @@ -- | 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"+-- in GHC.Tc.Solver.Dict noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys   = not $ anyBag matchable_given $@@ -1565,9 +1742,9 @@   where     pred_w = mkClassPred clas tys -    matchable_given :: Ct -> Bool-    matchable_given ct-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct+    matchable_given :: DictCt -> Bool+    matchable_given (DictCt { di_ev = ev })+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ev       = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w        | otherwise@@ -1575,7 +1752,7 @@  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+-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Dict mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc   | prohibitedSuperClassSolve given_loc wanted_loc   = Nothing@@ -1633,13 +1810,13 @@       | otherwise       = False -    -- like startSolvingByUnification, but allows cbv variables to unify+    -- Like checkTopShape, but allows cbv variables to unify     can_unify :: TcTyVar -> MetaInfo -> Type -> Bool     can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note       | Just rhs_tv <- getTyVar_maybe rhs_ty       = case tcTyVarDetails rhs_tv of           MetaTv { mtv_info = TyVarTv } -> True-          MetaTv {}                     -> False  -- could unify with anything+          MetaTv {}                     -> False  -- Could unify with anything           SkolemTv {}                   -> True           RuntimeUnk                    -> True       | otherwise  -- not a var on the RHS@@ -1720,7 +1897,7 @@    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.+   Note [Type equality cycles] in GHC.Tc.Solver.Equality    This is just like case 6, and we say "no". Saying "no" here is    essential in getting the parser to type-check, with its use of DisambECP. @@ -1811,7 +1988,7 @@ -- 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)+                      firstJusts (NE.map (lookupBag cbv) cbvs_stack)   = tyfam_app   | otherwise   = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)@@ -1819,15 +1996,16 @@ -- | Push a fresh environment onto the cycle-breaker var stack. Useful -- when entering a nested implication. pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack-pushCycleBreakerVarStack = ([] <|)+pushCycleBreakerVarStack = (emptyBag <|)  -- | 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+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.@@ -1837,3 +2015,199 @@ 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++solveOneFromTheOther ct_i ct_w+  | CtWanted { ctev_loc = loc_w } <- ev_w+  , prohibitedSuperClassSolve loc_i loc_w+  -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+  = -- Inert must be Given+    KeepWork++  | CtWanted {} <- ev_w+  = -- Inert is Given or Wanted+    case ev_i of+      CtGiven {} -> KeepInert+        -- work is Wanted; inert is Given: easy choice.++      CtWanted {} -- Both are Wanted+        -- If only one has no pending superclasses, use it+        -- Otherwise we can get infinite superclass expansion (#22516)+        -- in silly cases like   class C T b => C a b where ...+        | not is_psc_i, is_psc_w     -> KeepInert+        | is_psc_i,     not is_psc_w -> KeepWork++        -- If only one is a WantedSuperclassOrigin (arising from expanding+        -- a Wanted class constraint), keep the other: wanted superclasses+        -- may be unexpected by users+        | not is_wsc_orig_i, is_wsc_orig_w     -> KeepInert+        | is_wsc_orig_i,     not is_wsc_orig_w -> KeepWork++        -- otherwise, just choose the lower span+        -- reason: if we have something like (abs 1) (where the+        -- Num constraint cannot be satisfied), it's better to+        -- get an error about abs than about 1.+        -- This test might become more elaborate if we see an+        -- opportunity to improve the error messages+        | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert+        | otherwise                        -> KeepWork++  -- From here on the work-item is Given++  | CtWanted { ctev_loc = loc_i } <- ev_i+  , 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 == lvl_w+  = same_level_strategy++  | otherwise   -- Both are Given, levels differ+  = different_level_strategy+  where+     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+       | isIPLikePred pred = if lvl_w > lvl_i then KeepWork  else KeepInert+       | otherwise         = if lvl_w > lvl_i then KeepInert else KeepWork+       -- See Note [Replacement vs keeping] part (1)+       -- For the isIPLikePred 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. Example:++             f :: (Eq a, Ord a) => a -> Bool+             f x = x == x++           Eager superclass expansion gives us two [G] Eq a constraints. We+           want to keep the one from the user-written Eq a, not the superclass+           selection. This means we report the Ord a as redundant with+           -Wredundant-constraints, not the Eq a.++           Getting this wrong was #20602. See also+           Note [Tracking redundant constraints] in GHC.Tc.Solver.++       (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,18 +4,20 @@ -- | 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,+    tcAppMapToBag, foldTcAppMap, delTcApp,      EqualCtList, filterEqualCtList, addToEqualCtList+   ) where  import GHC.Prelude@@ -24,6 +26,9 @@ 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@@ -128,9 +133,6 @@  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]@@ -139,34 +141,12 @@   = 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,25 +154,8 @@ 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Solving CallStack constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.  Suppose f :: HasCallStack => blah.  Then@@ -204,7 +167,7 @@     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+* We cannonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by   pushing the call-site info on the stack, and changing the CtOrigin   to record that has been done.    Bind:  s1 = pushCallStack <site-info> s2@@ -241,12 +204,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 +225,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 +245,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 +260,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,9 @@         FrontendResult(..),          -- Renamer types-        ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin,+        ErrCtxt,         ImportAvails(..), emptyImportAvails, plusImportAvails,-        WhereFrom(..), mkModDeps,+        mkModDeps,          -- Typechecker types         TcTypeEnv, TcBinderStack, TcBinder(..),@@ -56,7 +57,7 @@         CompleteMatch, CompleteMatches,          -- Template Haskell-        ThStage(..), SpliceType(..), PendingStuff(..),+        ThStage(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),         topStage, topAnnStage, topSpliceStage,         ThLevel, impLevel, outerLevel, thLevel,         ForeignSrcLang(..), THDocs, DocLoc(..),@@ -71,7 +72,7 @@         isPartialSig, hasCompleteSig,          -- Misc other types-        TcId, TcIdSet,+        TcId,         NameShape(..),         removeBindingShadowing,         getPlatform,@@ -102,31 +103,35 @@ 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.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.Fixity.Env import GHC.Types.Annotations import GHC.Types.CompleteMatch@@ -136,12 +141,9 @@ 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@@ -159,24 +161,21 @@ 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 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  -- | A 'NameShape' is a substitution on 'Name's that can be used -- to refine the identities of a hole while we are renaming interfaces@@ -245,7 +244,7 @@                              -- Includes all info about imported things                              -- BangPattern is to fix leak, see #15111 -        env_ut   :: {-# UNPACK #-} !Char,   -- Tag for Uniques+        env_um   :: {-# UNPACK #-} !Char,   -- Mask for Uniques          env_gbl  :: gbl,     -- Info about things defined at the top level                              -- of the module being compiled@@ -442,9 +441,7 @@         tcg_default :: Maybe [Type],           -- ^ Types used for defaulting. @Nothing@ => no @default@ decl -        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@@ -509,6 +506,8 @@           -- 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,@@ -687,22 +686,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 +772,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 +789,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 +812,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 +850,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- {- ************************************************************************ *                                                                      *@@ -1418,214 +921,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 +975,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@@ -1779,7 +1075,7 @@       -- Zonked constraints containing the unfilled metavariables that       -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins]       -- in GHC.Tc.Solver-  -> TcPluginM [DefaultingProposal]+  -> TcPluginM DefaultingPluginResult  -- | A plugin for controlling defaulting. data DefaultingPlugin = forall s. DefaultingPlugin
− 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,500 @@+module GHC.Tc.Types.BasicTypes (+  -- * TcBinder+    TcBinderStack+  , TcId+  , TcBinder(..)++  -- * Signatures+  , TcSigFun+  , TcIdSigInfo(..)+  , TcSigInfo(..)+  , TcPatSynInfo(..)+  , TcIdSigInst(..)+  , isPartialSig+  , hasCompleteSig++  -- * TcTyThing+  , TcTyThing(..)+  , IdBindingInfo(..)+  , IsGroupClosed(..)+  , RhsNames+  , ClosedTypeId+  , tcTyThingCategory+  , tcTyThingTyCon_maybe+  , pprTcTyThingCategory+  ) where++import GHC.Prelude++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.Tc.Types.Origin+import GHC.Tc.Utils.TcType++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++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 "[partial signature]" <+> 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++---------------------------+-- 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
@@ -6,41 +6,49 @@ -- | 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+        -- Constraints         Xi, Ct(..), Cts,-        emptyCts, andCts, andManyCts, pprCts,         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,-        isEmptyCts,-        isPendingScDict, pendingScDict_maybe,+        isEmptyCts, emptyCts, andCts, ctsPreds,+        isPendingScDictCt, isPendingScDict, pendingScDict_maybe,         superClassesMightHelp, getPendingWantedScs,         isWantedCt, isGivenCt,-        isUserTypeError, getUserTypeErrorMsg,-        ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,+        isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg,+        isUnsatisfiableCt_maybe,+        ctEvidence, updCtEvidence,+        ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,         ctRewriters,         ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv,-        mkNonCanonical, mkNonCanonicalCt, mkGivens,-        mkIrredCt,-        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,-        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,-        ctEvRewriters,+        mkNonCanonical, mkGivens,         tyCoVarsOfCt, tyCoVarsOfCts,         tyCoVarsOfCtList, tyCoVarsOfCtsList, +        -- Particular forms of constraint+        EqCt(..),    eqCtEvidence, eqCtLHS,+        DictCt(..),  dictCtEvidence,+        IrredCt(..), irredCtEvidence, mkIrredCt, ctIrredCt, irredCtPred,++        -- QCInst+        QCInst(..), pendingScInst_maybe,++        ExpansionFuel, doNotExpand, consumeFuel, pendingFuel,+        assertFuelPrecondition, assertFuelPreconditionStrict,+         CtIrredReason(..), isInsolubleReason,          CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,-        cteOK, cteImpredicative, cteTypeFamily,+        cteOK, cteImpredicative, cteTypeFamily, cteCoercionHole,         cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,+        cteConcrete, cteSkolemEscape,+        impredicativeProblem, insolubleOccursProblem, solubleOccursProblem, -        cterHasNoProblem, cterHasProblem, cterHasOnlyProblem,+        cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, cterHasOnlyProblems,         cterRemoveProblem, cterHasOccursCheck, cterFromKind, -        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,-        eqCanEqLHS, +        CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,+        canEqLHSKind, canEqLHSType, eqCanEqLHS,+         Hole(..), HoleSort(..), isOutOfScopeHole,         DelayedError(..), NotConcreteError(..),         NotConcreteReason(..),@@ -49,8 +57,8 @@         isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,         addInsols, dropMisleading, addSimples, addImplics, addHoles,         addNotConcreteError, addDelayedErrors,-        tyCoVarsOfWC,-        tyCoVarsOfWCList, insolubleWantedCt, insolubleEqCt, insolubleCt,+        tyCoVarsOfWC, tyCoVarsOfWCList,+        insolubleWantedCt, insolubleCt, insolubleIrredCt,         insolubleImplic, nonDefaultableTyVarsOfWC,          Implication(..), implicationPrototype, checkTelescopeSkol,@@ -63,25 +71,30 @@         ctLocTypeOrKind_maybe,         ctLocDepth, bumpCtLocDepth, isGivenLoc,         setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,-        pprCtLoc,+        pprCtLoc, adjustCtLoc, adjustCtLocTyConBinder, +        -- CtLocEnv+        CtLocEnv(..), setCtLocEnvLoc, setCtLocEnvLvl, getCtLocEnvLoc, getCtLocEnvLvl, ctLocEnvInGeneratedCode,+         -- CtEvidence         CtEvidence(..), TcEvDest(..),-        mkKindLoc, toKindLoc, mkGivenLoc,         isWanted, isGiven,-        ctEvRole, setCtEvPredType, setCtEvLoc,+        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,+        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,+        ctEvRewriters, ctEvUnique, tcEvDestUnique,+        mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc,+        ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens,         tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,-        ctEvUnique, tcEvDestUnique, +        -- RewriterSet         RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet,-           -- exported concretely only for anyUnfilledCoercionHoles-        rewriterSetFromType, rewriterSetFromTypes, rewriterSetFromCo,-        addRewriterSet,+           -- exported concretely only for zonkRewriterSet+        addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts,          wrapType,          CtFlavour(..), ctEvFlavour,-        CtFlavourRole, ctEvFlavourRole, ctFlavourRole,+        CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCtFlavourRole,         eqCanRewrite, eqCanRewriteFR,          -- Pretty printing@@ -93,9 +106,6 @@  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@@ -107,15 +117,15 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin+import GHC.Tc.Types.CtLocEnv  import GHC.Core  import GHC.Core.TyCo.Ppr import GHC.Utils.FV import GHC.Types.Var.Set-import GHC.Driver.Session+import GHC.Builtin.Names import GHC.Types.Basic-import GHC.Types.Unique import GHC.Types.Unique.Set  import GHC.Utils.Outputable@@ -127,7 +137,6 @@ 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 )@@ -139,7 +148,6 @@   - {- ************************************************************************ *                                                                      *@@ -148,8 +156,103 @@ *   These are the constraints the low-level simplifier works with      * *                                                                      * ************************************************************************+-} -Note [CEqCan occurs check]+-- | 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++data Ct+  = CDictCan      DictCt+  | CIrredCan     IrredCt      -- A "irreducible" constraint (non-canonical)+  | CEqCan        EqCt         -- A canonical equality constraint+  | CQuantCan     QCInst       -- A quantified constraint+  | CNonCanonical CtEvidence   -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad++--------------- DictCt --------------++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++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 constrtaints. It satisfies these invariants:+  * (TyEq:OC) lhs does not occur in rhs (occurs check)+              Note [EqCt occurs check]+  * (TyEq:F) rhs has no foralls+      (this avoids substituting a forall for the tyvar in other types)+  * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant]+  * (TyEq:N) If the equality is representational, rhs is not headed by a saturated+    application of a newtype TyCon. See GHC.Tc.Solver.Equality+    Note [No top-level newtypes on RHS of representational equalities].+    (Applies only when constructor of newtype is in scope.)+  * (TyEq:U) An EqCt is not immediately unifiable. If we can unify a:=ty, we+    will not form an EqCt (a ~ ty).+  * (TyEq:CH) rhs does not mention any coercion holes that resulted from fixing up+    a hetero-kinded equality.  See Note [Equalities with incompatible kinds] in+    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.@@ -158,11 +261,12 @@  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 variables, the occurs-check looks deeply including kinds of+  type variables. This is because a CEqCan over a meta-variable is+  also used to inform unification, in+  GHC.Tc.Solver.Monad.checkTouchableTyVarEq. If the LHS appears+  anywhere in the RHS, at all, unification will create an infinite+  structure which is bad.  * For type family applications, the occurs-check is shallow; it looks   only in places where we might rewrite. (Specifically, it does not@@ -176,105 +280,75 @@   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+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 '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 EqCt -- An equality constraint; see Note [Canonical equalities]+  = 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+    } -data Ct-  -- Atomic canonical constraints-  = CDictCan {  -- e.g.  Num ty-      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]+-- | A 'CanEqLHS' is a type that can appear on the left of a canonical+-- equality: a type variable or /exactly-saturated/ type family application.+data CanEqLHS+  = TyVarLHS TcTyVar+  | TyFamLHS TyCon  -- ^ TyCon of the family+             [Xi]   -- ^ Arguments, /exactly saturating/ the family -      cc_class  :: Class,-      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi+instance Outputable CanEqLHS where+  ppr (TyVarLHS tv)              = ppr tv+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args) -      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-    }+eqCtEvidence :: EqCt -> CtEvidence+eqCtEvidence = eq_ev -  | CIrredCan {  -- These stand for yet-unusable predicates-      cc_ev     :: CtEvidence,   -- See Note [Ct/evidence invariant]-      cc_reason :: CtIrredReason+eqCtLHS :: EqCt -> CanEqLHS+eqCtLHS = eq_lhs -        -- 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]+--------------- IrredCt -------------- -        -- The definitely-insoluble case is for things like-        --    Int ~ Bool      tycons don't match-        --    a ~ [a]         occurs check-    }+data IrredCt    -- These stand for yet-unusable predicates+                -- See Note [CIrredCan constraints]+  = IrredCt { ir_ev     :: CtEvidence   -- See Note [Ct/evidence invariant]+            , ir_reason :: CtIrredReason } -  | 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+mkIrredCt :: CtIrredReason -> CtEvidence -> Ct+mkIrredCt reason ev = CIrredCan (IrredCt { ir_ev = ev, ir_reason = reason }) -      cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev-    }+irredCtEvidence :: IrredCt -> CtEvidence+irredCtEvidence = ir_ev -  | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad-      cc_ev  :: CtEvidence-    }+irredCtPred :: IrredCt -> PredType+irredCtPred = ctEvPred . irredCtEvidence -  | 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+ctIrredCt :: CtIrredReason -> Ct -> IrredCt+ctIrredCt _      (CIrredCan ir) = ir+ctIrredCt reason ct             = IrredCt { ir_ev = ctEvidence ct+                                          , ir_reason = reason } ---------------- | 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 IrredCt where+  ppr irred = ppr (CIrredCan irred) -instance Outputable CanEqLHS where-  ppr (TyVarLHS tv)              = ppr tv-  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)+--------------- QCInst -------------- ------------- data QCInst  -- A much simplified version of ClsInst-             -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+             -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve   = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty                                  -- Always Given         , qci_tvs  :: [TcTyVar]  -- The tvs         , qci_pred :: TcPredType -- The ty-        , qci_pend_sc :: Bool    -- Same as cc_pend_sc flag in CDictCan-                                 -- Invariant: True => qci_pred is a ClassPred+        , qci_pend_sc :: ExpansionFuel+             -- Invariants: qci_pend_sc > 0 =>+             --       (a) qci_pred is a ClassPred+             --       (b) this class has superclass(es), and+             --       (c) the superclass(es) are not explored yet+             -- Same as di_pend_sc flag in DictCt+             -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver     }  instance Outputable QCInst where@@ -392,35 +466,40 @@ -- | 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@)+      -- ^ 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;+   -- ^ 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.+    -- ^ 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,+    -- ^ 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@+    -- ^ 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@@ -429,6 +508,7 @@ isInsolubleReason ReprEqReason              = False isInsolubleReason ShapeMismatchReason       = True isInsolubleReason AbstractTyConReason       = True+isInsolubleReason PluginReason              = True  ------------------------------------------------------------------------------ --@@ -436,7 +516,7 @@ -- ------------------------------------------------------------------------------ --- | A set of problems in checking the validity of a type equality.+-- | A /set/ of problems in checking the validity of a type equality. -- See 'checkTypeEq'. newtype CheckTyEqResult = CTER Word8 @@ -449,20 +529,35 @@ cterHasNoProblem (CTER 0) = True cterHasNoProblem _        = False --- | An individual problem that might be logged in a 'CheckTyEqResult'+-- | 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+cteImpredicative, cteTypeFamily, cteInsolubleOccurs,+  cteSolubleOccurs, cteCoercionHole, 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++cteCoercionHole    = CTEP (bit 4)   -- Coercion hole encountered+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@@ -477,6 +572,9 @@ 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) @@ -513,19 +611,32 @@ 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"+  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 ]+           = 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")+          , (cteCoercionHole,    "cteCoercionHole") ]+ {- Note [CIrredCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CIrredCan constraints are used for constraints that are "stuck"@@ -546,10 +657,10 @@ 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).+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] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -598,13 +709,7 @@ -}  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 }+mkNonCanonical ev = CNonCanonical ev  mkGivens :: CtLoc -> [EvId] -> [Ct] mkGivens loc ev_ids@@ -615,9 +720,21 @@                                        , ctev_loc = loc })  ctEvidence :: Ct -> CtEvidence-ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev-ctEvidence ct = cc_ev ct+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 @@ -672,14 +789,17 @@       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)"+         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+ ----------------------------------- -- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated -- type family application?@@ -689,6 +809,11 @@   | Just tv <- getTyVar_maybe xi   = Just $ TyVarLHS tv +  | otherwise+  = canTyFamEqLHS_maybe xi++canTyFamEqLHS_maybe :: Xi -> Maybe CanEqLHS+canTyFamEqLHS_maybe xi   | Just (tc, args) <- tcSplitTyConApp_maybe xi   , isTypeFamilyTyCon tc   , args `lengthIs` tyConArity tc@@ -873,7 +998,7 @@ -- | 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 :: PredType -> Maybe ErrorMsgType getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred                                   : map getUserTypeErrorMsg (subTys pred)   where@@ -887,29 +1012,53 @@                               Just (_,ts) -> ts                  (t,ts) -> t : ts -isUserTypeError :: PredType -> Bool-isUserTypeError pred = case getUserTypeErrorMsg pred of-                             Just _ -> True-                             _      -> False+-- | Is this an user error message type, i.e. either the form @TypeError err@ or+-- @Unsatisfiable err@?+isTopLevelUserTypeError :: PredType -> Bool+isTopLevelUserTypeError pred =+  isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) +-- | Does this constraint contain an user error message?+--+-- That is, the type is either of the form @Unsatisfiable err@, or it contains+-- a type of the form @TypeError msg@, either at the top level or nested inside+-- the type.+containsUserTypeError :: PredType -> Bool+containsUserTypeError pred =+  isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred)++-- | Is this type an unsatisfiable constraint?+-- If so, return the error message.+isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType+isUnsatisfiableCt_maybe t+  | Just (tc, [msg]) <- splitTyConApp_maybe t+  , tc `hasKey` unsatisfiableClassNameKey+  = Just msg+  | otherwise+  = Nothing+ isPendingScDict :: Ct -> Bool-isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc--- Says whether this is a CDictCan with cc_pend_sc is True;+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-isPendingScDict _ = False+isPendingScDictCt (DictCt { di_pend_sc = f }) = pendingFuel f  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 })+-- 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_pend_sc = True })-                      = Just (qci { qci_pend_sc = False })-pendingScInst_maybe _ = Nothing+pendingScInst_maybe qci@(QCI { qci_pend_sc = f })+  | pendingFuel f = Just (qci { qci_pend_sc = doNotExpand })+  | otherwise     = Nothing  superClassesMightHelp :: WantedConstraints -> Bool -- ^ True if taking superclasses of givens, or of wanteds (to perhaps@@ -924,21 +1073,22 @@      might_help_ct ct = not (is_ip ct) -    is_ip (CDictCan { cc_class = cls }) = isIPClass cls-    is_ip _                             = False+    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' <- pendingScDict_maybe ct-               = (ct':acc, ct')+    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.Canonical.+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)@@ -995,17 +1145,14 @@ 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))+ctsPreds :: Cts -> [PredType]+ctsPreds cts = foldr ((:) . ctPred) [] cts  {- ************************************************************************@@ -1063,9 +1210,9 @@ 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 }+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@@ -1148,11 +1295,11 @@           EqPred NomEq lhs rhs             | Just tv <- getTyVar_maybe lhs             , isConcreteTyVar tv-            , not (isConcrete rhs)+            , not (isConcreteType rhs)             -> unitVarSet tv             | Just tv <- getTyVar_maybe rhs             , isConcreteTyVar tv-            , not (isConcrete lhs)+            , not (isConcreteType lhs)             -> unitVarSet tv           _ -> emptyVarSet @@ -1165,52 +1312,27 @@ 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++    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+--   a) an insoluble constraint as per 'insolubleCt', 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+-- See Note [Given insolubles].+insolubleWantedCt ct = insolubleCt ct &&+                       not (arisesFromGivens ct) &&+                       not (isWantedWantedFunDepOrigin (ctOrigin ct)) -insolubleIrredCt :: CtEvidence -> CtIrredReason -> Bool+insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble -- -- This function is critical for accurate pattern-match overlap warnings.@@ -1219,59 +1341,18 @@ -- 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'+  -- 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@@ -1279,6 +1360,18 @@   -- >   Assert 'True  _errMsg = ()   -- >   Assert _check errMsg  = errMsg +-- | 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+ -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool@@ -1322,31 +1415,6 @@ 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:@@ -1388,17 +1456,16 @@       ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?        ic_warn_inaccessible :: Bool,-                                 -- True  <=> -Winaccessible-code is enabled-                                 -- at construction. See+                                 -- True <=> we should report inaccessible code                                  -- Note [Avoid -Winaccessible-code when deriving]                                  -- in GHC.Tc.TyCl.Instance -      ic_env   :: TcLclEnv,-                                 -- Records the TcLClEnv at the time of creation.+      ic_env   :: !CtLocEnv,+                                 -- Records the context 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.+                                 -- 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@@ -1420,15 +1487,15 @@       ic_status   :: ImplicStatus     } -implicationPrototype :: Implication-implicationPrototype+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_env        = panic "newImplic:env"             , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" +            , ic_env        = ct_loc_env               -- The rest have sensible default values             , ic_skols      = []             , ic_given      = []@@ -1443,7 +1510,7 @@        { 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_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]@@ -1989,6 +2056,9 @@ setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence setCtEvLoc ctev loc = ctev { ctev_loc = loc } +arisesFromGivens :: Ct -> Bool+arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct)+ -- | Set the type of CtEvidence. -- -- This function ensures that the invariants on 'CtEvidence' hold, by updating@@ -2049,41 +2119,26 @@ emptyRewriterSet :: RewriterSet emptyRewriterSet = RewriterSet emptyUniqSet -isEmptyRewriterSet :: RewriterSet -> Bool-isEmptyRewriterSet (RewriterSet set) = isEmptyUniqSet set--addRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet-addRewriterSet = coerce (addOneToUniqSet @CoercionHole)+unitRewriterSet :: CoercionHole -> RewriterSet+unitRewriterSet = coerce (unitUniqSet @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+unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet+unionRewriterSet = coerce (unionUniqSets @CoercionHole) --- | 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+isEmptyRewriterSet :: RewriterSet -> Bool+isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole) --- | 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+addRewriter :: RewriterSet -> CoercionHole -> RewriterSet+addRewriter = coerce (addOneToUniqSet @CoercionHole) -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 ()+rewriterSetFromCts :: Bag Ct -> RewriterSet+-- Take a bag of Wanted equalities, and collect them as a RewriterSet+rewriterSetFromCts cts+  = foldr add emptyRewriterSet cts   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 = \ _ _ _ -> () }+    add ct rw_set = case ctEvidence ct of+         CtWanted { ctev_dest = HoleDest hole } -> rw_set `addRewriter` hole+         _                                      -> rw_set  {- ************************************************************************@@ -2116,14 +2171,20 @@ ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel 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 :: 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)+ctFlavourRole (CDictCan di_ct) = dictCtFlavourRole di_ct+ctFlavourRole (CEqCan eq_ct)   = eqCtFlavourRole eq_ct+ctFlavourRole ct               = ctEvFlavourRole (ctEvidence ct)  {- Note [eqCanRewrite] ~~~~~~~~~~~~~~~~~~~~~~@@ -2166,11 +2227,23 @@  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.)+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.)++* 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.++* 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@@ -2183,26 +2256,74 @@  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.+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. -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.+Note [Prioritise Wanteds with empty RewriterSet]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq,+we priorities constraints that have no rewriters. Here's why. -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!+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.InertSet.extendWorkListEq, and extendWorkListEqs.++Wrinkles++(WRW1) Before checking for an empty RewriterSet, we zonk the RewriterSet,+  because some of those CoercionHoles may have been filled in since we last+  looked: see GHC.Tc.Solver.Monad.emitWork.++(WRW2) 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@@ -2363,9 +2484,9 @@ 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+subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool+subGoalDepthExceeded reductionDepth (SubGoalDepth d)+  = mkIntWithInf d > reductionDepth  {- ************************************************************************@@ -2381,38 +2502,57 @@ -}  data CtLoc = CtLoc { ctl_origin   :: CtOrigin-                   , ctl_env      :: TcLclEnv+                   , 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 } -  -- The TcLclEnv includes particularly-  --    source location:  tcl_loc   :: RealSrcSpan-  --    context:          tcl_ctxt  :: [ErrCtxt]-  --    binder stack:     tcl_bndrs :: TcBinderStack-  --    level:            tcl_tclvl :: TcLevel+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 } -mkKindLoc :: TcType -> TcType   -- original *types* being compared-          -> CtLoc -> CtLoc-mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)-                        (KindEqOrigin s1 s2 (ctLocOrigin loc)-                                      (ctLocTypeOrKind_maybe loc))+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 } -mkGivenLoc :: TcLevel -> SkolemInfoAnon -> TcLclEnv -> CtLoc+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      = setLclEnvTcLevel env tclvl+          , ctl_env      = setCtLocEnvLvl env tclvl           , ctl_t_or_k   = Nothing    -- this only matters for error msgs           , ctl_depth    = initialSubGoalDepth } -ctLocEnv :: CtLoc -> TcLclEnv+ctLocEnv :: CtLoc -> CtLocEnv ctLocEnv = ctl_env  ctLocLevel :: CtLoc -> TcLevel-ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc)+ctLocLevel loc = getCtLocEnvLvl (ctLocEnv loc)  ctLocDepth :: CtLoc -> SubGoalDepth ctLocDepth = ctl_depth@@ -2421,13 +2561,13 @@ ctLocOrigin = ctl_origin  ctLocSpan :: CtLoc -> RealSrcSpan-ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc lcl+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 (setLclEnvLoc lcl loc)+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 }@@ -2439,7 +2579,7 @@ updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd   = ctl { ctl_origin = upd orig } -setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc+setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc setCtLocEnv ctl env = ctl { ctl_env = env }  pprCtLoc :: CtLoc -> SDoc@@ -2447,4 +2587,4 @@ -- 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)]+        , text "at" <+> ppr (getCtLocEnvLoc lcl)]
+ compiler/GHC/Tc/Types/CtLocEnv.hs view
@@ -0,0 +1,60 @@+module GHC.Tc.Types.CtLocEnv (+    CtLocEnv(..)+  , getCtLocEnvLoc+  , getCtLocEnvLvl+  , setCtLocEnvLvl+  , setCtLocRealLoc+  , setCtLocEnvLoc+  , ctLocEnvInGeneratedCode+  ) where++import GHC.Prelude++import GHC.Types.SrcLoc+import GHC.Types.Name.Reader++import GHC.Tc.Types.BasicTypes+import GHC.Tc.Utils.TcType+import GHC.Tc.Types.ErrCtxt+++-- | 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,16 @@+module GHC.Tc.Types.ErrCtxt where++import GHC.Prelude+import GHC.Types.Var.Env+import GHC.Tc.Zonk.Monad (ZonkM)+import GHC.Utils.Outputable++-- | Additional context to include in an error message, e.g.+-- "In the type signature ...", "In the ambiguity check for ...", etc.+type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, SDoc))+        -- 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
compiler/GHC/Tc/Types/Evidence.hs view
@@ -22,7 +22,7 @@   isEmptyEvBindMap,   evBindMapToVarSet,   varSetMinusEvBindMap,-  EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,+  EvBindInfo(..), EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,   evBindVar, isCoEvBindsVar,    -- * EvTerm (already a CoreExpr)@@ -70,6 +70,7 @@ import GHC.Core import GHC.Core.Class (Class, classSCSelId ) import GHC.Core.FVs   ( exprSomeFreeVars )+import GHC.Core.InstEnv ( Canonical )  import GHC.Utils.Misc import GHC.Utils.Panic@@ -229,7 +230,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@@ -447,24 +448,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 :: Canonical -- 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 -> Canonical -> 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.@@ -655,7 +661,7 @@  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.+   just like a regular IP; see GHC.Tc.Solver.Dict.tryInertDicts.     For example, the occurrence of `?stk` in @@ -685,7 +691,7 @@         [W] d1 : IP "stk" CallStack      with CtOrigin = OccurrenceOf "foo" -   * We /solve/ this constraint, in GHC.Tc.Solver.Canonical.canClassNC+   * We /solve/ this constraint, in GHC.Tc.Solver.Dict.canDictNC      by emitting a NEW Wanted         [W] d2 :: IP "stk" CallStack      with CtOrigin = IPOccOrigin@@ -771,7 +777,7 @@  - When we emit a new wanted CallStack from rule (2) 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.@@ -845,8 +851,7 @@    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+     , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind      = evVarsOfTerm rhs `unionVarSet` needs      | otherwise      = needs@@ -940,12 +945,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
+ 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+  , getLclEnvThStage+  , setLclEnvTcLevel+  , setLclEnvLoc+  , setLclEnvRdrEnv+  , setLclEnvBinderStack+  , setLclEnvErrCtxt+  , setLclEnvThStage+  , 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 HsExpansion]+        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    :: 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_env  :: TcTypeEnv    -- The local type environment:+                                 -- Ids and TyVars defined in this module++    }++getLclEnvThStage :: TcLclEnv -> ThStage+getLclEnvThStage = tcl_th_ctxt . tcl_lcl_ctxt++setLclEnvThStage :: ThStage -> TcLclEnv -> TcLclEnv+setLclEnvThStage s = modifyLclCtxt (\env -> env { tcl_th_ctxt = s })++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, 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++---------------------------+-- 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,3 @@+module GHC.Tc.Types.LclEnv where++data TcLclEnv
compiler/GHC/Tc/Types/Origin.hs view
@@ -25,16 +25,19 @@    -- * CtOrigin and CallStack   isPushCallStackOrigin, callStackOriginFS,+  ClsInstOrQC(..), NakedScFlag(..),+   -- * FixedRuntimeRep origin   FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..),   pprFixedRuntimeRepContext,   StmtOrigin(..), RepPolyFun(..), ArgPos(..),-  ClsInstOrQC(..), NakedScFlag(..),    -- * Arrow command origin   FRRArrowContext(..), pprFRRArrowContext,   ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, +  -- InstanceWhat+  InstanceWhat(..), SafeOverlapping   ) where  import GHC.Prelude@@ -83,11 +86,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@@ -278,7 +292,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@@ -308,7 +322,7 @@ -- shares a certain 'Unique'. mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo mkSkolemInfo sk_anon = do-  u <- liftIO $! uniqFromTag 's'+  u <- liftIO $! uniqFromMask 's'   return (SkolemInfo u sk_anon)  getSkolemInfo :: SkolemInfo -> SkolemInfoAnon@@ -467,7 +481,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)@@ -578,9 +592,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.@@ -596,7 +609,7 @@   | CycleBreakerOrigin       CtOrigin   -- origin of the original constraint -      -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical+      -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality   | FRROrigin       FixedRuntimeRepOrigin @@ -806,13 +819,6 @@          , 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))@@ -822,6 +828,10 @@          , ppr cls_inst          , text "is provided by" <+> quotes (ppr mod)] +pprCtOrigin (ImpedanceMatching x)+  = vcat [ text "arising when matching required constraints"+         , text "in a group involving" <+> quotes (ppr x)]+ pprCtOrigin (CycleBreakerOrigin orig)   = pprCtOrigin orig @@ -914,11 +924,12 @@ 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"+pprCtO (ImpedanceMatching {})       = text "combining required constraints" + {- ********************************************************************* *                                                                      *              CallStacks and CtOrigin@@ -997,6 +1008,11 @@       -- ^ 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@@ -1401,3 +1417,42 @@ 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-staged 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 }++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/TH.hs view
@@ -0,0 +1,122 @@+module GHC.Tc.Types.TH (+    SpliceType(..)+  , SpliceOrBracket(..)+  , ThStage(..)+  , PendingStuff(..)+  , ThLevel+  , topStage+  , topAnnStage+  , topSpliceStage+  , thLevel+  , impLevel+  , outerLevel+  ) where++import GHCi.RemoteTypes+import qualified Language.Haskell.TH as TH+import GHC.Tc.Types.Evidence+import GHC.Utils.Outputable+import GHC.Prelude+import GHC.Utils.Panic+import GHC.Tc.Types.TcRef+import GHC.Tc.Types.Constraint+import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )++---------------------------+-- Template Haskell stages and levels+---------------------------++data SpliceType = Typed | Untyped+data SpliceOrBracket = IsSplice | IsBracket++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.++-}
+ 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
@@ -31,6 +31,7 @@   ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,   ExpRhoType,   mkCheckExpType,+  checkingExpType_maybe, checkingExpType,    SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -38,7 +39,7 @@   -- TcLevel   TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,   strictlyDeeperThan, deeperThanOrSame, sameDepthAs,-  tcTypeLevel, tcTyVarLevel, maxTcLevel,+  tcTypeLevel, tcTyVarLevel, maxTcLevel, minTcLevel,    --------------------------------   -- MetaDetails@@ -47,7 +48,7 @@   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,   ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,-  isConcreteTyVarTy, isConcreteTyVarTy_maybe,+  isConcreteTyVarTy, isConcreteTyVarTy_maybe, isConcreteInfo,   isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,@@ -72,7 +73,7 @@   tcSplitTyConApp, tcSplitTyConApp_maybe,   tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe,-  tcSplitSigmaTy, tcSplitNestedSigmaTys,+  tcSplitSigmaTy, tcSplitNestedSigmaTys, tcSplitIOType_maybe,    ---------------------------------   -- Predicates.@@ -84,7 +85,7 @@   isTauTy, isTauTyCon, tcIsTyVarTy,   isPredTy, isTyVarClassPred,   checkValidClsArgs, hasTyVarHead,-  isRigidTy,+  isRigidTy, anyTy_maybe,     -- Re-exported from GHC.Core.TyCo.Compare@@ -97,8 +98,6 @@   -- Misc type manipulators    deNoteType,-  orphNamesOfType, orphNamesOfCo,-  orphNamesOfTypes, orphNamesOfCoCon,   getDFunTyKey, evVarPred,   ambigTkvsOfTy, @@ -117,23 +116,9 @@   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--  ---------------------------------   -- Patersons sizes-  PatersonSize(..), PatersonSizeFailure(..),+  PatersonSize(..), PatersonCondFailure(..),+  PatersonCondFailureContext(..),   ltPatersonSize,   pSizeZero, pSizeOne,   pSizeType, pSizeTypeX, pSizeTypes,@@ -163,8 +148,8 @@   mkTyConTy, mkTyVarTy, mkTyVarTys,   mkTyCoVarTy, mkTyCoVarTys, -  isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,-  mkClassPred,+  isClassPred, isEqPrimPred, isIPLikePred, isEqPred,+  isEqualityClass, mkClassPred,   tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,   isRuntimeRepVar, isFixedRuntimeRepKind,   isVisiblePiTyBinder, isInvisiblePiTyBinder,@@ -207,7 +192,7 @@    ---------------------------------   -- argument visibility-  tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible+  tyConVisibilities, isNextTyConArgVisible, isNextArgVisible    ) where @@ -221,12 +206,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 +217,12 @@   , 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.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@@ -250,15 +231,11 @@ 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 +349,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@@ -406,51 +383,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@@ -513,7 +446,17 @@ 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 :: String -> ExpType -> TcType+checkingExpType _   (Check ty) = ty+checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)+ {- ********************************************************************* *                                                                      *           SyntaxOpType@@ -657,7 +600,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@@ -672,7 +615,7 @@     | 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@@ -719,6 +662,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@@ -801,6 +747,9 @@ maxTcLevel :: TcLevel -> TcLevel -> TcLevel maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) +minTcLevel :: TcLevel -> TcLevel -> TcLevel+minTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `min` b)+ topTcLevel :: TcLevel -- See Note [TcLevel assignment] topTcLevel = TcLevel 0   -- 0 = outermost level@@ -1204,6 +1153,10 @@   | otherwise   = Nothing +isConcreteInfo :: MetaInfo -> Bool+isConcreteInfo (ConcreteTv {}) = True+isConcreteInfo _               = False+ -- | Is this type variable a concrete type variable, i.e. -- it is a metavariable with 'ConcreteTv' 'MetaInfo'? isConcreteTyVar :: TcTyVar -> Bool@@ -1373,7 +1326,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 +1349,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'@@ -1850,7 +1803,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 ):@@ -2048,251 +2001,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 +2013,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 +2022,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 +2098,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 +2131,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 +2153,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.   --@@ -2533,11 +2254,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/Zonk/Monad.hs view
@@ -0,0 +1,112 @@+{-# 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++   -- ** 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 #-}++-- | 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/Avail.hs view
@@ -7,33 +7,18 @@ 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,   ) where  import GHC.Prelude@@ -41,9 +26,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 +35,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 qualified Data.Semigroup as S  -- -----------------------------------------------------------------------------@@ -66,7 +47,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 +56,19 @@   --   -- > 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 ]--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.---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 +76,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 +99,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,110 +108,29 @@ -- 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-  where-    to_either (NormalGreName n) = Left n-    to_either (FieldGreName fl) = Right fl-- -- ----------------------------------------------------------------------------- -- Utility @@ -322,7 +142,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 +152,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 +164,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  @@ -393,19 +213,3 @@ instance NFData AvailInfo where   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)-
compiler/GHC/Types/Basic.hs view
@@ -16,9 +16,11 @@  {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Types.Basic (         LeftOrRight(..),@@ -34,14 +36,14 @@         FunctionOrData(..),          RecFlag(..), isRec, isNonRec, boolToRecFlag,-        Origin(..), isGenerated,+        Origin(..), isGenerated, DoPmc(..), requiresPMC,          RuleName, pprRuleName,          TopLevelFlag(..), isTopLevel, isNotTopLevel,          OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,+        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, hasNonCanonicalFlag,          Boxity(..), isBoxed, @@ -109,6 +111,8 @@         Levity(..), mightBeLifted, mightBeUnlifted,         TypeOrConstraint(..), +        TyConFlavour(..), TypeOrData(..), tyConFlavourAssoc_maybe,+         NonStandardDefaultingStrategy(..),         DefaultingStrategy(..), defaultNonStandardTyVars, @@ -124,12 +128,16 @@ 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 Control.DeepSeq ( NFData(..) )+import Data.Data+import Data.Maybe+import qualified Data.Semigroup as Semi++{-+************************************************************************ *                                                                      *           Binary choice *                                                                      *@@ -575,18 +583,63 @@ ************************************************************************ -} +-- | 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 DoPmc             deriving( Eq, Data )  isGenerated :: Origin -> Bool-isGenerated Generated = True-isGenerated FromSource = False+isGenerated Generated {} = True+isGenerated FromSource   = False  instance Outputable Origin where-  ppr FromSource  = text "FromSource"-  ppr Generated   = text "Generated"+  ppr FromSource      = text "FromSource"+  ppr (Generated pmc) = text "Generated" <+> 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 HsExpansion mechanism described in Note [Rebindable syntax and HsExpansion]+    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).+-}+ {- ************************************************************************ *                                                                      *@@ -620,6 +673,7 @@ hasIncoherentFlag mode =   case mode of     Incoherent   _ -> True+    NonCanonical _ -> True     _              -> False  hasOverlappableFlag :: OverlapMode -> Bool@@ -628,6 +682,7 @@     Overlappable _ -> True     Overlaps     _ -> True     Incoherent   _ -> True+    NonCanonical _ -> True     _              -> False  hasOverlappingFlag :: OverlapMode -> Bool@@ -636,8 +691,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,6 +753,16 @@     -- 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)  @@ -704,6 +775,7 @@    ppr (Overlapping  _) = text "[overlapping]"    ppr (Overlaps     _) = text "[overlap ok]"    ppr (Incoherent   _) = text "[incoherent]"+   ppr (NonCanonical _) = text "[noncanonical]"  instance Binary OverlapMode where     put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s@@ -711,6 +783,7 @@     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 +792,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)  @@ -1553,7 +1627,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@@ -1949,12 +2023,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,6 +2049,77 @@   = TypeLike | ConstraintLike   deriving( Eq, Ord, Data ) ++{- *********************************************************************+*                                                                      *+                          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 -> "data" }+      go ClosedTypeFamilyFlavour = "type family"+      go TypeSynonymFlavour      = "type synonym"+      go BuiltInTypeFlavour      = "built-in type"+      go PromotedDataConFlavour  = "promoted data constructor"++instance NFData tc => NFData (TyConFlavour tc) where+  rnf ClassFlavour = ()+  rnf (TupleFlavour !_) = ()+  rnf SumFlavour = ()+  rnf DataTypeFlavour = ()+  rnf NewtypeFlavour = ()+  rnf AbstractTypeFlavour = ()+  rnf (OpenFamilyFlavour !_ mb_tc) = rnf mb_tc+  rnf ClosedTypeFamilyFlavour = ()+  rnf TypeSynonymFlavour = ()+  rnf BuiltInTypeFlavour = ()+  rnf PromotedDataConFlavour = ()++-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour+tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc+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+  | IAmType+  deriving (Eq, Data)++instance Outputable TypeOrData where+  ppr IAmData = text "data"+  ppr IAmType = text "type"  {- ********************************************************************* *                                                                      *
compiler/GHC/Types/CostCentre.hs view
@@ -281,10 +281,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
compiler/GHC/Types/Demand.hs view
@@ -88,8 +88,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 ) @@ -964,15 +963,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,7 +983,10 @@ 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.@@ -998,11 +1000,9 @@     -- 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+      | isTerminatingType ty+      , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty+      = Just (map scaledThing field_tys)       | otherwise       = Nothing strictifyDictDmd _  dmd = dmd
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@@ -27,14 +29,22 @@    , Severity (..)    , Diagnostic (..)    , UnknownDiagnostic (..)+   , mkSimpleUnknownDiagnostic+   , mkUnknownDiagnostic+   , embedUnknownDiagnostic    , DiagnosticMessage (..)-   , DiagnosticReason (..)+   , DiagnosticReason (WarningWithFlag, ..)+   , ResolvedDiagnosticReason(..)    , DiagnosticHint (..)    , mkPlainDiagnostic    , mkPlainError    , mkDecoratedDiagnostic    , mkDecoratedError +   , pprDiagnostic++   , HasDefaultDiagnosticOpts(..)+   , defaultDiagnosticOpts    , NoDiagnosticOpts(..)     -- * Hints and refactoring actions@@ -91,9 +101,11 @@ import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import GHC.Utils.Json import GHC.Utils.Panic+import GHC.Unit.Module.Warnings (WarningCategory)  import Data.Bifunctor import Data.Foldable    ( fold )+import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) import Data.Typeable ( Typeable )@@ -150,7 +162,10 @@   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)+             ]  {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -206,6 +221,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,11 +240,10 @@ -- 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 (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where    -- | Type of configuration options for the diagnostic.   type DiagnosticOpts a-  defaultDiagnosticOpts :: DiagnosticOpts a    -- | Extract the error message text from a 'Diagnostic'.   diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc@@ -247,22 +271,40 @@   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 where+  UnknownDiagnostic :: (Diagnostic a, Typeable a)+                    => (opts -> DiagnosticOpts a) -- Inject the options of the outer context+                                                  -- into the options for the wrapped diagnostic.+                    -> a+                    -> UnknownDiagnostic opts -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+instance HasDefaultDiagnosticOpts opts => Diagnostic (UnknownDiagnostic opts) where+  type DiagnosticOpts (UnknownDiagnostic opts) = opts+  diagnosticMessage opts (UnknownDiagnostic f diag) = diagnosticMessage (f opts) diag+  diagnosticReason    (UnknownDiagnostic _ diag) = diagnosticReason  diag+  diagnosticHints     (UnknownDiagnostic _ diag) = diagnosticHints   diag+  diagnosticCode      (UnknownDiagnostic _ diag) = diagnosticCode    diag  -- A fallback 'DiagnosticOpts' which can be used when there are no options -- for a particular diagnostic. data NoDiagnosticOpts = NoDiagnosticOpts+instance HasDefaultDiagnosticOpts NoDiagnosticOpts where+  defaultOpts = NoDiagnosticOpts +-- | Make a "simple" unknown diagnostic which doesn't have any configuration options.+mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b+mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts)++-- | Make an unknown diagnostic which uses the same options as the context it will be embedded into.+mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a)+mkUnknownDiagnostic = UnknownDiagnostic id++-- | Embed a more complicated diagnostic which requires a potentially different options type.+embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts+embedUnknownDiagnostic = UnknownDiagnostic++--------------------------------------------------------------------------------+ pprDiagnostic :: forall e . Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e)                        , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ]@@ -287,7 +329,6 @@  instance Diagnostic DiagnosticMessage where   type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts-  defaultDiagnosticOpts = NoDiagnosticOpts   diagnosticMessage _ = diagMessage   diagnosticReason  = diagReason   diagnosticHints   = diagHints@@ -328,18 +369,75 @@ 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 +452,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 +474,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 +528,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@@ -494,8 +596,9 @@           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            code_doc =             case msg_class of@@ -508,26 +611,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 +754,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
compiler/GHC/Types/Error/Codes.hs view
@@ -20,15 +20,16 @@   where  import GHC.Prelude-import GHC.Types.Error  ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode )+import GHC.Types.Error  ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode, NoDiagnosticOpts )  import GHC.Hs.Extension ( GhcRn ) -import GHC.Driver.Errors.Types   ( DriverMessage )+import GHC.Core.InstEnv (LookupInstanceErrReason)+import GHC.Iface.Errors.Types+import GHC.Driver.Errors.Types   ( DriverMessage, GhcMessageOpts, DriverMessageOpts ) import GHC.Parser.Errors.Types   ( PsMessage, PsHeaderMessage ) import GHC.HsToCore.Errors.Types ( DsMessage ) import GHC.Tc.Errors.Types-import GHC.Tc.Utils.TcType      ( IllegalForeignTypeReason, TypeCannotBeMarshaledReason ) import GHC.Unit.Module.Warnings ( WarningTxt ) import GHC.Utils.Panic.Plain @@ -38,6 +39,7 @@ import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) ) import GHC.TypeNats ( Nat, KnownNat, natVal' ) + {- Note [Diagnostic codes] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Every time a new diagnostic (error or warning) is introduced to GHC,@@ -253,7 +255,6 @@   GhcDiagnosticCode "PsErrAtInPatPos"                               = 08382   GhcDiagnosticCode "PsErrParseErrorOnInput"                        = 66418   GhcDiagnosticCode "PsErrMalformedDecl"                            = 85316-  GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl"                  = 45054   GhcDiagnosticCode "PsErrNotADataCon"                              = 25742   GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed"                = 57342   GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax"           = 65719@@ -294,12 +295,17 @@   GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage"        = 75165   GhcDiagnosticCode "DriverRedirectedNoMain"                        = 95379   GhcDiagnosticCode "DriverHomePackagesNotClosed"                   = 03271+  GhcDiagnosticCode "DriverInconsistentDynFlags"                    = 74335+  GhcDiagnosticCode "DriverSafeHaskellIgnoredExtension"             = 98887+  GhcDiagnosticCode "DriverPackageTrustIgnored"                     = 83552+  GhcDiagnosticCode "DriverUnrecognisedFlag"                        = 93741+  GhcDiagnosticCode "DriverDeprecatedFlag"                          = 53692    -- 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@@ -323,12 +329,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 +343,7 @@   GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig"                = 44188   GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig"                 = 50058   GhcDiagnosticCode "TcRnShadowedName"                              = 63397+  GhcDiagnosticCode "TcRnInvalidWarningCategory"                    = 53573   GhcDiagnosticCode "TcRnDuplicateWarningDecls"                     = 00711   GhcDiagnosticCode "TcRnSimplifierTooManyIterations"               = 95822   GhcDiagnosticCode "TcRnIllegalPatSynDecl"                         = 82077@@ -356,7 +364,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 +372,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 +383,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@@ -401,22 +405,20 @@   GhcDiagnosticCode "TcRnDuplicateExport"                           = 47854   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@@ -425,14 +427,17 @@   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@@ -445,21 +450,16 @@   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@@ -468,42 +468,158 @@   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 "TcRnBindVarAlreadyInScope"                     = 69710+  GhcDiagnosticCode "TcRnBindMultipleVariables"                     = 92957+  GhcDiagnosticCode "TcRnIllegalKind"                               = 64861+  GhcDiagnosticCode "TcRnUnexpectedPatSigType"                      = 74097+  GhcDiagnosticCode "TcRnIllegalKindSignature"                      = 91382+  GhcDiagnosticCode "TcRnDataKindsError"                            = 68567    GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods"                 = 93006+  GhcDiagnosticCode "TcRnHsigFixityMismatch"                        = 93007+  GhcDiagnosticCode "TcRnHsigNoIface"                               = 93010+  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 "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 "TcRnLoopySuperclassSolve"                      = 36038+  GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl"          = 95159+  GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl"                  = 65669+  GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig"               = 45906+  GhcDiagnosticCode "TcRnIllegalRuleLhs"                            = 63294+  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 "TcRnBadlyStaged"                               = 28914+  GhcDiagnosticCode "TcRnStageRestriction"                          = 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 "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"                   = 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 "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"              = 69797 +  -- TcRnTypeApplicationsDisabled+  GhcDiagnosticCode "TypeApplication"                               = 23482+  GhcDiagnosticCode "TypeApplicationInPattern"                      = 17916++  -- PatSynInvalidRhsReason+  GhcDiagnosticCode "PatSynNotInvertible"                           = 69317+  GhcDiagnosticCode "PatSynUnboundVar"                              = 28572++  -- TcRnBadFieldAnnotation/BadFieldAnnotationReason+  GhcDiagnosticCode "LazyFieldsDisabled"                            = 81601+  GhcDiagnosticCode "UnpackWithoutStrictness"                       = 10107+  GhcDiagnosticCode "BackpackUnpackAbstractType"                    = 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 "TcRnInvalidInvisTyVarBndr"                     = 57916+  GhcDiagnosticCode "TcRnInvisBndrWithoutSig"                       = 92337+   -- IllegalNewtypeReason   GhcDiagnosticCode "DoesNotHaveSingleField"                        = 23517   GhcDiagnosticCode "IsNonLinear"                                   = 38291@@ -512,6 +628,18 @@   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 "BadImportAvailTyCon"                           = 56449+  GhcDiagnosticCode "BadImportAvailVar"                             = 12112+   -- TcRnPragmaWarning   GhcDiagnosticCode "WarningTxt"                                    = 63394   GhcDiagnosticCode "DeprecatedTxt"                                 = 68441@@ -540,6 +668,62 @@   GhcDiagnosticCode "DefaultDataInstDecl"                           = 39639   GhcDiagnosticCode "FunBindLacksEquations"                         = 52078 +  -- 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 "InstHeadNonClass"                              = 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 +740,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,14 +796,63 @@   GhcDiagnosticCode "DerivErrGenerics"                              = 30367   GhcDiagnosticCode "DerivErrEnumOrProduct"                         = 58291 +  -- Diagnostic codes for instance lookup+  GhcDiagnosticCode "LookupInstErrNotExact"                         = 10372+  GhcDiagnosticCode "LookupInstErrFlexiVar"                         = 10373+  GhcDiagnosticCode "LookupInstErrNotFound"                         = 10374+   -- 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"                          = 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 "NoDataKindsDC"                                 = 71015+  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   --@@ -609,8 +861,20 @@   -- and this includes outdated diagnostic codes for errors that GHC   -- no longer reports. These are collected below. -  GhcDiagnosticCode "Example outdated error"                        = 00000+  GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = 12222+  GhcDiagnosticCode "TcRnNoClassInstHead"                           = 56538+    -- The above two are subsumed by InstHeadNonClass [GHC-53946] +  GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = 40027+  GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = 69639+  GhcDiagnosticCode "TcRnMixedSelectors"                            = 40887+  GhcDiagnosticCode "TcRnBadBootFamInstDecl"                        = 06203+  GhcDiagnosticCode "TcRnBindInBootFile"                            = 11247+  GhcDiagnosticCode "TcRnUnexpectedTypeSplice"                      = 39180+  GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl"                  = 45054+  GhcDiagnosticCode "TcRnUnpromotableThing"                         = 88634+  GhcDiagnosticCode "UntouchableVariable"                           = 34699+ {- ********************************************************************* *                                                                      *                  Recurring into an argument@@ -636,24 +900,33 @@   ConRecursInto "GhcPsMessage"             = 'Just PsMessage   ConRecursInto "GhcTcRnMessage"           = 'Just TcRnMessage   ConRecursInto "GhcDsMessage"             = 'Just DsMessage-  ConRecursInto "GhcUnknownMessage"        = 'Just UnknownDiagnostic+  ConRecursInto "GhcUnknownMessage"        = 'Just (UnknownDiagnostic GhcMessageOpts)    ----------------------------------   -- Constructors of DriverMessage -  ConRecursInto "DriverUnknownMessage"     = 'Just UnknownDiagnostic+  ConRecursInto "DriverUnknownMessage"     = 'Just (UnknownDiagnostic DriverMessageOpts)   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 (UnknownDiagnostic NoDiagnosticOpts)   ConRecursInto "PsHeaderMessage"          = 'Just PsHeaderMessage    ----------------------------------   -- Constructors of TcRnMessage -  ConRecursInto "TcRnUnknownMessage"       = 'Just UnknownDiagnostic+  ConRecursInto "TcRnUnknownMessage"       = 'Just (UnknownDiagnostic TcRnMessageOpts)      -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage   ConRecursInto "TcRnMessageWithInfo"      = 'Just TcRnMessageDetailed@@ -661,16 +934,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 "TcRnTypeApplicationsDisabled" = 'Just TypeApplication +    -- 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 +1021,14 @@   ----------------------------------   -- Constructors of DsMessage -  ConRecursInto "DsUnknownMessage"         = 'Just UnknownDiagnostic+  ConRecursInto "DsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts)    ----------------------------------+  -- 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. @@ -782,11 +1111,11 @@ -- 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+         ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts)+         , HasType (UnknownDiagnostic opts) con f )+      => ConstructorCode con f ('Just (UnknownDiagnostic opts)) where+  gconstructorCode diag = case getType @(UnknownDiagnostic opts) @con @f diag of+    UnknownDiagnostic _ diag -> diagnosticCode diag  -- (*) Recursive instance: Recur into the given type. instance ( ConRecursInto con ~ 'Just ty, HasType ty con f
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,9 +95,6 @@ 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@@ -148,8 +110,10 @@     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)@@ -165,55 +129,27 @@     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+        case getUserData bh of+          UserData{ ud_put_binding_name = put_binding_name } ->+              put_binding_name bh ac     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
@@ -24,7 +24,7 @@ import Data.Data hiding (Fixity, Prefix, Infix)  data Fixity = Fixity SourceText Int FixityDirection-  -- Note [Pragma source text]+  -- Note [Pragma source text] in "GHC.Types.SourceText"   deriving Data  instance Outputable Fixity where
compiler/GHC/Types/ForeignCall.hs view
@@ -99,7 +99,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 +117,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.@@ -233,7 +233,7 @@         = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""  -- The filename for a C header file--- Note [Pragma source text] in GHC.Types.SourceText+-- Note [Pragma source text] in "GHC.Types.SourceText" data Header = Header SourceText FastString     deriving (Eq, Data) @@ -247,7 +247,7 @@ --        '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 -- Note [Pragma source text] in "GHC.Types.SourceText"                    (Maybe Header) -- header to include for this type                    (SourceText,FastString) -- the type itself     deriving (Eq, Data)
+ compiler/GHC/Types/GREInfo.hs view
@@ -0,0 +1,281 @@+{-# 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+      -- | No particular information... e.g. a function+    = 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++instance NFData GREInfo where+  rnf Vanilla = ()+  rnf UnboundGRE = ()+  rnf (IAmTyCon tc) = rnf tc+  rnf (IAmConLike info) = rnf info+  rnf (IAmRecField info) = rnf info++plusGREInfo :: GREInfo -> GREInfo -> GREInfo+plusGREInfo Vanilla Vanilla = Vanilla+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++* Whether the contructor 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]++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 about the record fields of a constructor.+--+-- See Note [Local constructor info in the renamer]+data ConInfo+  = ConHasRecordFields (NonEmpty FieldLabel)+  | ConHasPositionalArgs+  | ConIsNullary+  deriving stock Eq+  deriving Data++instance NFData ConInfo where+  rnf ConIsNullary = ()+  rnf ConHasPositionalArgs = ()+  rnf (ConHasRecordFields flds) = rnf flds++mkConInfo :: Arity -> [FieldLabel] -> ConInfo+mkConInfo 0 _ = ConIsNullary+mkConInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields+                   $ NonEmpty.nonEmpty fields++conInfoFields :: ConInfo -> [FieldLabel]+conInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields+conInfoFields ConHasPositionalArgs = []+conInfoFields ConIsNullary = []++instance Outputable ConInfo 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 Outputable ConLikeName where+  ppr = ppr . conLikeName_Name++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
@@ -21,17 +21,21 @@   , noStarIsTypeHints   ) where +import Language.Haskell.Syntax.Expr (LHsExpr)+import Language.Haskell.Syntax (LPat, LIdP)+ 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) import GHC.Core.Coercion-import GHC.Core.Type (PredType)+import GHC.Core.FamInstEnv (FamFlavor)+import GHC.Core.TyCon (TyCon)+import GHC.Core.Type (PredType, Type) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)@@ -39,12 +43,11 @@ 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 )+ -- | The bindings we have available in scope when -- suggesting an explicit type signature. data AvailableBindings@@ -247,7 +250,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@@ -304,13 +306,18 @@     -}   | SuggestTypeSignatureForm -    {-| 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 +327,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. @@ -395,16 +410,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 +428,52 @@     -}   | SuggestSpecialiseVisibilityHints Name +    {-| Suggest renaming implicitly quantified type variable in case it+        captures a term's name.+    -}+  | SuggestRenameTypeVariable+   | LoopySuperclassSolveHint PredType ClsInstOrQC -  {-| Suggest binding explicitly; e.g   data T @k (a :: F k) = .... -}-  | SuggestBindTyVarExplicitly Name+  | 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+ -- | 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@@ -441,9 +490,23 @@ -- | 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 it isn't a type.+  | CouldRemoveTypeKeyword ModuleName+  -- | The module exports what we want, but it's a type and we have @ExplicitNamespaces@ on.+  | CouldAddTypeKeyword ModuleName+  -- | Suggest importing a data constructor to bring it into scope+  | ImportDataCon+      -- | Where to suggest importing the 'DataCon' from.+      --+      -- The 'Bool' tracks whether to suggest using an import of the form+      -- @import (pattern Foo)@, depending on whether @-XPatternSynonyms@+      -- was enabled.+      { ies_suggest_import_from :: Maybe (ModuleName, Bool)+        -- | The 'OccName' of the parent of the data constructor.+      , ies_parent :: OccName }  -- | Explain how something is in scope. data HowInScope@@ -454,7 +517,7 @@  data SimilarName   = SimilarName Name-  | SimilarRdrName RdrName HowInScope+  | SimilarRdrName RdrName (Maybe HowInScope)  -- | Something is promoted to the type-level without a promotion tick. data UntickedPromotedThing
compiler/GHC/Types/Hint/Ppr.hs view
@@ -12,10 +12,13 @@ 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.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(..))@@ -132,12 +135,19 @@          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@@ -193,10 +203,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,6 +215,8 @@            <+> quotes (ppr name) <+> text "has an INLINABLE pragma"          where            mod = nameModule name+    SuggestRenameTypeVariable+      -> text "Consider renaming the type variable."     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." ]@@ -215,77 +225,156 @@           what = case cls_or_qc of             IsClsInst -> text "instance context"             IsQC {}   -> text "context of the quantified constraint"-    SuggestBindTyVarExplicitly tv-      -> text "bind" <+> quotes (ppr tv)-         <+> text "explicitly with" <+> quotes (char '@' <> ppr tv)+    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"  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 (CouldAddTypeKeyword mod)+ = vcat [ text "Add the" <+> quotes (text "type")+          <+> text "keyword to the import statement:"+        , nest 2 $ text "import"+            <+> ppr mod+            <+> parens_sp (text "type" <+> pprPrefixOcc occ_name)+        ]+  where+    parens_sp d = parens (space <> d <> space)+pprImportSuggestion occ_name (CouldRemoveTypeKeyword mod)+  = vcat [ text "Remove the" <+> quotes (text "type")+             <+> text "keyword from the import statement:"+         , nest 2 $ text "import"+             <+> ppr mod+             <+> parens_sp (pprPrefixOcc occ_name) ]+  where+    parens_sp d = parens (space <> d <> space)+pprImportSuggestion dc_occ (ImportDataCon Nothing parent_occ)+  = text "Import the data constructor" <+> quotes (ppr dc_occ) <+>+    text "of" <+> quotes (ppr parent_occ)+pprImportSuggestion dc_occ (ImportDataCon (Just (mod, patsyns_enabled)) parent_occ)+  = vcat $ [ text "Use"+           , nest 2 $ text "import"+               <+> ppr mod+               <+> parens_sp (pprPrefixOcc parent_occ <> parens_sp (pprPrefixOcc dc_occ))+           , text "or"+           , nest 2 $ text "import"+               <+> ppr mod+               <+> parens_sp (pprPrefixOcc parent_occ <> text "(..)")+           ] ++ if patsyns_enabled+                then [ text "or"+                     , nest 2 $ text "import"+                         <+> ppr mod+                         <+> parens_sp (text "pattern" <+> pprPrefixOcc dc_occ)+                     ]+                else []+  where+    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++pprPrefixUnqual :: Name -> SDoc+pprPrefixUnqual name =+  pprPrefixOcc (getOccName name)
compiler/GHC/Types/IPE.hs view
@@ -9,6 +9,7 @@ import GHC.Prelude  import GHC.Types.Name+import GHC.Data.FastString import GHC.Types.SrcLoc import GHC.Core.DataCon @@ -20,7 +21,7 @@  -- | 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.
compiler/GHC/Types/Id.hs view
@@ -480,23 +480,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,8 +527,8 @@                         _                 -> 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@@ -834,15 +834,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 []
compiler/GHC/Types/Id/Info.hs view
@@ -8,9 +8,11 @@ Haskell. [WDP 94/11]) -} --{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,7 +20,7 @@         -- * The IdDetails type         IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,         JoinArity, isJoinIdDetails_maybe,-        RecSelParent(..),+        RecSelParent(..), recSelParentName, recSelFirstConName,          -- * The IdInfo type         IdInfo,         -- Abstract@@ -95,6 +97,7 @@ import GHC.Types.Basic import GHC.Core.DataCon import GHC.Core.TyCon+import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn import GHC.Types.ForeignCall import GHC.Unit.Module@@ -105,11 +108,11 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Stg.InferTags.TagSig+import GHC.StgToCmm.Types (LambdaFormInfo) +import Data.Data ( Data ) import Data.Word -import GHC.StgToCmm.Types (LambdaFormInfo)- -- infixl so you can say (id `set` a `set` b) infixl  1 `setRuleInfo`,           `setArityInfo`,@@ -120,7 +123,8 @@           `setCafInfo`,           `setDmdSigInfo`,           `setCprSigInfo`,-          `setDemandInfo`+          `setDemandInfo`,+          `setLFInfo` {- ************************************************************************ *                                                                      *@@ -138,8 +142,9 @@    -- | 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 @@ -150,9 +155,14 @@                                 --  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 +  | 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+   | PrimOpId PrimOp Bool        -- ^ The 'Id' is for a primitive operator                                 -- True <=> is representation-polymorphic,                                 --          and hence has no binding@@ -268,17 +278,40 @@ 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+ 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,7 +335,7 @@ 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"@@ -369,7 +402,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)
compiler/GHC/Types/Id/Make.hs view
@@ -65,6 +65,7 @@  import GHC.Types.Literal import GHC.Types.SourceText+import GHC.Types.RepType ( countFunRepArgs ) import GHC.Types.Name.Set import GHC.Types.Name import GHC.Types.ForeignCall@@ -87,6 +88,10 @@ 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))+ {- ************************************************************************ *                                                                      *@@ -465,7 +470,7 @@                              -- (dictionary superclass or method)             -> Class -> Id 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)@@ -476,11 +481,16 @@     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  = mkInvisForAllTys 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@@ -590,11 +600,18 @@                    `setInlinePragInfo`     wkr_inline_prag                    `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,                                                            -- even if arity = 0+                   `setLFInfo`             wkr_lf_info           -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon      wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }     wkr_arity = dataConRepArity data_con +    -- 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@@ -603,6 +620,8 @@                   `setArityInfo` 1      -- Arity 1                   `setInlinePragInfo`     dataConWrapperInlinePragma                   `setUnfoldingInfo`      newtype_unf+                               -- See W1 in Note [LFInfo of DataCon workers and wrappers]+                  `setLFInfo` (panic "mkDataConWorkId: we shouldn't look at LFInfo for newtype worker ids")     id_arg1      = mkScaledTemplateLocal 1 (head arg_tys)     res_ty_args  = mkTyCoVarTys univ_tvs     newtype_unf  = assertPpr (null ex_tcvs && isSingleton arg_tys)@@ -613,6 +632,89 @@                    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`,+             and `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 --@@ -704,11 +806,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@@ -788,25 +899,15 @@     -- needs a wrapper. This wrapper is injected into the program later in the     -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy,     -- along with the accompanying implementation in getTyConImplicitBinds.-    wrapper_reqd-      | isTypeDataTyCon tycon-        -- `type data` declarations never have data-constructor wrappers-        -- Their data constructors only live at the type level, in the-        -- form of PromotedDataCon, and therefore do not need wrappers.-        -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.-      = False--      | otherwise-      = (not new_tycon+    wrapper_reqd =+        (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)-       || isFamInstTyCon tycon -- Cast result--      || dataConUserTyVarsNeedWrapper data_con+      || (dataConUserTyVarsNeedWrapper 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@@ -815,7 +916,19 @@                      --                      -- NB: All GADTs return true from this function, but there                      -- is one exception that we must check below.-+         && not (isTypeDataTyCon tycon))+                     -- An exception to this rule is `type data` declarations.+                     -- Their data constructors only live at the type level and+                     -- therefore do not need wrappers.+                     -- See Note [Type data declarations] in GHC.Rename.Module.+                     --+                     -- Note that the other checks in this definition will+                     -- return False for `type data` declarations, as:+                     --+                     -- - They cannot be newtypes+                     -- - They cannot have strict fields+                     -- - They cannot be data family instances+                     -- - They cannot have datatype contexts       || not (null stupid_theta)                      -- If the data constructor has a datatype context,                      -- we need a wrapper in order to drop the stupid arguments.@@ -2074,10 +2187,15 @@ 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:++* 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 [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Types/Literal.hs view
@@ -32,7 +32,7 @@         , mkLitFloat, mkLitDouble         , mkLitChar, mkLitString         , mkLitBigNat-        , mkLitNumber, mkLitNumberWrap+        , mkLitNumber, mkLitNumberWrap, mkLitNumberMaybe          -- ** Operations on Literals         , literalType@@ -410,6 +410,12 @@ mkLitNumber platform nt i =   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
compiler/GHC/Types/Name.hs view
@@ -2,6 +2,8 @@ {-# 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@@ -63,8 +65,8 @@         -- ** Predicates on 'Name's         isSystemName, isInternalName, isExternalName,         isTyVarName, isTyConName, isDataConName,-        isValName, isVarName, isDynLinkName,-        isWiredInName, isWiredIn, isBuiltInSyntax,+        isValName, isVarName, isDynLinkName, isFieldName,+        isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName,         isHoleName,         wiredInNameTyThing_maybe,         nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage,@@ -91,6 +93,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@@ -103,6 +106,8 @@ import Control.DeepSeq import Data.Data import qualified Data.Semigroup as S+import GHC.Types.Basic (Boxity(Boxed))+import GHC.Builtin.Uniques (isTupleTyConUnique)  {- ************************************************************************@@ -157,6 +162,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` ()@@ -282,6 +291,9 @@ isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True isBuiltInSyntax _                                           = False +isTupleTyConName :: Name -> Bool+isTupleTyConName = isJust . isTupleTyConUnique . getUnique+ isExternalName (Name {n_sort = External _})    = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True isExternalName _                               = False@@ -339,7 +351,14 @@ -- Return the pun for a name if available. -- Used for pretty-printing under ListTuplePuns. namePun_maybe :: Name -> Maybe FastString-namePun_maybe name | getUnique name == getUnique listTyCon = Just (fsLit "[]")+namePun_maybe name+  | getUnique name == getUnique listTyCon = Just (fsLit "[]")++  | Just (Boxed, ar) <- isTupleTyConUnique (getUnique name)+  , ar /= 1 = Just (fsLit $ '(' : commas ar ++ ")")+  where+    commas ar = replicate (ar-1) ','+ namePun_maybe _ = Nothing  nameIsLocalOrFrom :: Module -> Name -> Bool@@ -424,6 +443,9 @@ isVarName :: Name -> Bool isVarName = isVarOcc . nameOccName +isFieldName :: Name -> Bool+isFieldName = isFieldOcc . nameOccName+ isSystemName (Name {n_sort = System}) = True isSystemName _                        = False @@ -627,21 +649,31 @@  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+  = 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 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++   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 @@ -674,12 +706,8 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc+pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc 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?   | debug         = pp_mod <> ppr_occ_name occ                      <> braces (hsep [if is_wired then text "(w)" else empty,                                       pprNameSpaceBrief (occNameSpace occ),@@ -695,9 +723,8 @@     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 +733,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,7 +743,7 @@                                 -- so print the unique  -pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc+pprModulePrefix :: PprStyle -> Module -> 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 $@@ -728,28 +754,23 @@                           <> 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.
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,4 +1,3 @@- {-# LANGUAGE RankNTypes #-}  -- | The Name Cache@@ -30,7 +29,9 @@  import Control.Concurrent.MVar import Control.Monad+import Control.Applicative + {-  Note [The Name Cache]@@ -58,8 +59,8 @@ Note [Built-in syntax and the OrigNameCache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower-their cost we use two tricks,+Built-in syntax like unboxed sums and punned syntax like tuples are quite+ubiquitous. To lower their cost we use two tricks,    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.@@ -69,13 +70,14 @@      in GHC.Iface.Binary and for details.    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.+     OccNames (in isBuiltInOcc_maybe and isPunOcc_maybe) to avoid bloating+     the name cache with them.  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,+emits built-in and punned syntax directly as Exact RdrNames, and 2) built-in+and punned syntax never needs to looked-up during interface loading due to (a).+It turns out that there are two reasons why we might look up an Orig RdrName+for built-in and punned syntax,    * If you use setRdrNameSpace on an Exact RdrName it may be     turned into an Orig RdrName.@@ -98,12 +100,12 @@ type OrigNameCache   = ModuleEnv (OccEnv Name)  takeUniqFromNameCache :: NameCache -> IO Unique-takeUniqFromNameCache (NameCache c _) = uniqFromTag c+takeUniqFromNameCache (NameCache c _) = uniqFromMask 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+  , Just name <- isBuiltInOcc_maybe occ <|> isPunOcc_maybe mod occ   =     -- See Note [Known-key names], 3(c) in GHC.Builtin.Names         -- Special case for tuples; there are too many         -- of them to pre-populate the original-name cache
compiler/GHC/Types/Name/Env.hs view
@@ -15,12 +15,16 @@          -- ** 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 +51,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 +108,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 +118,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 +142,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,7 +166,7 @@ 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
compiler/GHC/Types/Name/Occurrence.hs view
@@ -3,8 +3,11 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable #-}+--{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}  -- |@@ -29,7 +32,7 @@          -- ** Construction         -- $real_vs_source_data_constructors-        tcName, clsName, tcClsName, dataName, varName,+        tcName, clsName, tcClsName, dataName, varName, fieldName,         tvName, srcDataName,          -- ** Pretty Printing@@ -37,11 +40,12 @@          -- * The 'OccName' type         OccName,        -- Abstract, instance of Outputable-        pprOccName,+        pprOccName, occNameMangledFS,          -- ** Construction         mkOccName, mkOccNameFS,         mkVarOcc, mkVarOccFS,+        mkRecFieldOcc, mkRecFieldOccFS,         mkDataOcc, mkDataOccFS,         mkTyVarOcc, mkTyVarOccFS,         mkTcOcc, mkTcOccFS,@@ -49,7 +53,10 @@         mkDFunOcc,         setOccNameSpace,         demoteOccName,+        demoteOccTvName,         promoteOccName,+        varToRecFieldOcc,+        recFieldToVarOcc,         HasOccName(..),          -- ** Derived 'OccName's@@ -66,31 +73,41 @@         mkSuperDictSelOcc, mkSuperDictAuxOcc,         mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,         mkInstTyCoOcc, mkEqPredCoOcc,-        mkRecFldSelOcc,         mkTyConRepOcc,          -- ** Deconstruction         occNameFS, occNameString, occNameSpace,          isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,+        isFieldOcc, fieldOcc_maybe,         parenSymOcc, startsWithUnderscore,          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,+        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,         tidyOccName, avoidClashesOccEnv, delTidyOccEnvList,@@ -101,9 +118,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 +128,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 +144,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 +264,9 @@ tvName      = TvName varName     = VarName +fieldName :: FastString -> NameSpace+fieldName = FldName+ isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True isDataConNameSpace _        = False@@ -181,30 +280,44 @@ 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.@@ -214,7 +327,17 @@ demoteNameSpace DataName = Nothing demoteNameSpace TvName = Nothing demoteNameSpace TcClsName = Just DataName+demoteNameSpace (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 +345,7 @@ promoteNameSpace VarName = Just TvName promoteNameSpace TcClsName = Nothing promoteNameSpace TvName = Nothing+promoteNameSpace (FldName {}) = Nothing  {- ************************************************************************@@ -246,7 +370,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 +403,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 +458,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,6 +510,11 @@   space' <- demoteNameSpace 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@@ -353,91 +534,291 @@ *                                                                      * ************************************************************************ -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  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+-------------------------------------------------------------------------------- +type OccSet = FastStringEnv (UniqSet NameSpace)+ emptyOccSet       :: OccSet unitOccSet        :: OccName -> OccSet mkOccSet          :: [OccName] -> OccSet@@ -445,27 +826,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       = emptyFsEnv+unitOccSet (OccName ns s) = unitFsEnv s (unitUniqSet ns)+mkOccSet          = extendOccSetList emptyOccSet+extendOccSet      occs (OccName ns s) = extendFsEnv occs s (unitUniqSet ns)+extendOccSetList  = foldl extendOccSet+unionOccSets      = plusFsEnv_C unionUniqSets+unionManyOccSets  = foldl' unionOccSets emptyOccSet+elemOccSet (OccName ns s) occs = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s+isEmptyOccSet     = isNullUFM  {- ************************************************************************@@ -481,7 +853,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 +864,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 +892,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@@ -652,10 +1034,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] @@ -886,6 +1264,24 @@ {- ************************************************************************ *                                                                      *+                            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 +1297,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
@@ -23,6 +23,7 @@ import GHC.Utils.Misc import GHC.Builtin.Types.Prim ( fUNTyConName ) import GHC.Builtin.Types+import Data.Maybe (isJust)   {-@@ -67,7 +68,7 @@  -- | 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)@@ -78,7 +79,7 @@   unit_state = ue_units unit_env   home_unit  = ue_homeUnit unit_env -mkQualName :: GlobalRdrEnv -> QueryQualifyName+mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName mkQualName env = qual_name where   qual_name mod occ         | [gre] <- unqual_gres@@ -96,7 +97,8 @@         = NameQual (greQualModName gre)          | null qual_gres-        = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)+        = if null $ lookupGRE env $+               LookupRdrName (mkRdrQual (moduleName mod) occ) SameNameSpace           then NameNotInScope1           else NameNotInScope2 @@ -120,18 +122,20 @@             , tYPETyConName             , fUNTyConName, unrestrictedFunTyConName             , oneDataConName+            , listTyConName             , manyDataConName ]+          || isJust (isTupleTyOcc_maybe mod occ)          right_name gre = greDefinitionModule gre == Just mod -        unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env-        qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)+        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 +151,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
compiler/GHC/Types/Name/Reader.hs view
@@ -5,1351 +5,2038 @@  {-# 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+{-# 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, demoteRdrNameTv, 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, minusLocalRdrEnvList,++        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's+        GlobalRdrEnvX, GlobalRdrEnv, IfGlobalRdrEnv,+        emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,+        extendGlobalRdrEnv, greOccName,+        pprGlobalRdrEnv, globalRdrEnvElts,++        -- ** Looking up 'GlobalRdrElt's+        FieldsOrSelectors(..), filterFieldGREs, allowGRE,++        LookupGRE(..), lookupGRE,+        WhichGREs(.., AllRelevantGREs, RelevantGREsFOS),+        greIsRelevant,+        LookupChild(..),++        lookupGRE_Name,+        lookupGRE_FieldLabel,+        getGRE_NameQualifier_maybes,+        transformGREs, pickGREs, pickGREsModExp,++        -- * 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,+        forceGlobalRdrEnv, hydrateGlobalRdrEnv,+        isLocalGRE, isImportedGRE, isRecFldGRE,+        fieldGREInfo,+        isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE,+        unQualOK, qualSpecOK, unQualSpecOK,+        pprNameProvenance,+        mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE,+        mkLocalConLikeGRE, mkLocalFieldGREs,+        gresToNameSet,++        -- ** Shadowing+        greClashesWith, shadowNames,++        -- ** Information attached to a 'GlobalRdrElt'+        ConLikeName(..),+        GREInfo(..), RecFieldInfo(..),+        plusGREInfo,+        recFieldConLike_maybe, recFieldInfo_maybe,+        fieldGRE_maybe, fieldGRELabel,++        -- ** Parent information+        Parent(..), greParent_maybe,+        mkParent, availParent,+        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),+        importSpecLoc, importSpecModule, isExplicitItem, bestImport,++        -- * 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+    ( NameEnv, nonDetNameEnvElts, emptyNameEnv, extendNameEnv_Acc )+import GHC.Types.Name.Set+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.Unit.Module++import GHC.Utils.Misc as Utils+import GHC.Utils.Outputable+import GHC.Utils.Panic++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`+-- > ( ~ )+--+-- - '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++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 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+  = 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)+++{- 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++instance NFData IfGlobalRdrElt where+  rnf !_ = ()++-- | 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++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 contructors 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+         , 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++-- | 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++-- | 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+    :: OccName  -- ^ the 'OccName' to look up+    -> LookupChild+         -- ^ information to decide which 'GlobalRdrElt's+         -- are valid children after looking up+    -> LookupGRE info++-- | 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++-- | 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 }++data LookupChild+  = LookupChild+  { wantedParent :: Name+     -- ^ the parent we are looking up children of+  , lookupDataConFirst :: Bool+     -- ^ for type constructors, should we look in the data constructor+     -- namespace first?+  , prioritiseParent :: Bool+    -- ^ should we prioritise getting the right 'Parent'?+    --+    --  - @True@: prioritise getting the right 'Parent'+    --  - @False@: prioritise getting the right 'NameSpace'+    --+    -- See Note [childGREPriority].+  }++-- | 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 competing metrics for finding the "best"+'GlobalRdrElt' that a particular 'OccName' resolves to:++  - does the resolved 'GlobalRdrElt' have the correct parent?+  - does the resolved 'GlobalRdrElt' have the same 'NameSpace' as the 'OccName'?++(A) and (B) have competing requirements.++For the example of (A) above, we know that the child 'D' of 'T' must live+in the data namespace, so we look up the OccName 'OccName DataName "D"' and+prioritise the lookup results based on the 'NameSpace'.+This means we get an error message of the form:++  The type constructor 'T' is not the parent of the data constructor 'D'.++as opposed to the rather unhelpful and confusing:++  The type constructor 'T' is not the parent of the type constructor 'D'.++See test case T11970.++For the example of (B) above, the fixity declaration for +++ lies inside the+class, so we should prioritise looking up 'GlobalRdrElt's whose parent is 'C'.+Not doing so led to #23664.+-}++-- | Scoring priority function for looking up children 'GlobalRdrElt'.+--+-- We score by 'Parent' and 'NameSpace', with higher priorities having lower+-- numbers. Which lexicographic order we use ('Parent' or 'NameSpace' first)+-- is determined by the first argument; see Note [childGREPriority].+childGREPriority :: LookupChild -- ^ what kind of child do we want,+                                -- e.g. what should its parent be?+                 -> NameSpace   -- ^ what 'NameSpace' are we originally looking in?+                 -> GlobalRdrEltX info+                                -- ^ the result of looking up; it might be in a different+                                -- 'NameSpace', which is used to determine the score+                                -- (in the first component)+                 -> Maybe (Int, Int)+childGREPriority (LookupChild { wantedParent = wanted_parent+                              , lookupDataConFirst = try_dc_first+                              , prioritiseParent = par_first })+  ns gre =+    case child_ns_prio $ greNameSpace gre of+      Nothing -> Nothing+      Just ns_prio ->+        let par_prio = parent_prio $ greParent gre+        in Just $ if par_first+                  then (par_prio, ns_prio)+                  else (ns_prio, par_prio)+          -- See Note [childGREPriority].++  where+      -- Pick out the possible 'NameSpace's in order of priority.+      child_ns_prio :: (NameSpace -> Maybe Int)+      child_ns_prio other_ns+        | other_ns == ns+        = Just 0+        | isTermVarOrFieldNameSpace ns+        , isTermVarOrFieldNameSpace other_ns+        = Just 0+        | isValNameSpace varName+        , other_ns == tcName+        -- 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+        | ns == tcName+        , other_ns == dataName+        , try_dc_first -- try data namespace before type/class namespace?+        = Just (-1)+        | otherwise+        = Nothing++      parent_prio :: Parent -> Int+      parent_prio (ParentIs other_parent)+        | other_parent == wanted_parent = 0+        | otherwise                     = 1+      parent_prio NoParent              = 0++-- | 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 occ which_child ->+    let ns = occNameSpace occ+        all_gres = concat $ lookupOccEnv_AllNameSpaces env occ+    in highestPriorityGREs (childGREPriority which_child 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'+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 -> 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_qual = True+                                   , 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 )++-- | 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_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 :: 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++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 []
compiler/GHC/Types/RepType.hs view
@@ -84,12 +84,11 @@   = False  -- INVARIANT: the result list is never empty.-typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]+typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep typePrimRepArgs ty-  | [] <- reps-  = [VoidRep]-  | otherwise-  = reps+  = case reps of+      [] -> VoidRep :| []+      (x:xs) ->   x :| xs   where     reps = typePrimRep ty @@ -124,6 +123,10 @@       | 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@@ -312,8 +315,10 @@  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 +335,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@@ -636,8 +641,10 @@ 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,7 +696,7 @@ -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty-  | [LiftedRep] <- typePrimRep ty+  | [BoxedRep _] <- typePrimRep ty   , Just tc <- tyConAppTyCon_maybe (unwrapType ty)   , isDataTyCon tc   = False
+ 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@@ -11,45 +14,57 @@ import GHC.Utils.Binary import GHC.Unit.Types --- 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)+ 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@@ -70,15 +85,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)  @@ -313,12 +323,3 @@  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)
compiler/GHC/Types/SrcLoc.hs view
@@ -64,6 +64,9 @@         isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan,         containsSpan, isNoSrcSpan, +        -- ** Predicates on RealSrcSpan+        isPointRealSpan,+         -- * StringBuffer locations         BufPos(..),         getBufPos,
compiler/GHC/Types/Tickish.hs view
@@ -25,6 +25,7 @@ ) where  import GHC.Prelude+import GHC.Data.FastString  import GHC.Core.Type @@ -153,8 +154,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)
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] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -257,7 +266,7 @@                                           Just (ATyCon tc)                                       RecSelId { sel_tycon = RecSelPatSyn ps } ->                                           Just (AConLike (PatSynCon ps))-                                      ClassOpId cls               ->+                                      ClassOpId cls _             ->                                           Just (ATyCon (classTyCon cls))                                       _other                      -> Nothing tyThingParent_maybe _other = Nothing@@ -276,22 +285,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, 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)+                , 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 conLikesWithFields 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,196 @@+-----------------------------------------------------------------------------+--+-- 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 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+  = go [] thing+  where+    go ss thing+      = case tyThingParent_maybe thing of+          Just parent ->+            go (getOccName thing : ss) parent+          Nothing ->+            pprTyThing+              (show_sub { ss_how_much = ShowSome ss (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 xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs 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 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
@@ -30,12 +30,9 @@          pprUniqueAlways, -        mkTag,         mkUniqueGrimily,-        mkUniqueIntGrimily,         getKey,         mkUnique, unpkUnique,-        mkUniqueInt,         eqUnique, ltUnique,         incrUnique, stepUnique, @@ -55,12 +52,11 @@  import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Utils.Word64 (intToWord64, word64ToInt)+import GHC.Utils.Panic.Plain  -- just for implementing a fast [0,61) -> Char function import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) -import GHC.Word         ( Word64 ) import Data.Char        ( chr, ord )  import Language.Haskell.Syntax.Module.Name@@ -72,19 +68,19 @@ *                                                                      * ************************************************************************ -Note [Uniques and tags]+Note [Uniques and masks] ~~~~~~~~~~~~~~~~~~~~~~~~-A `Unique` in GHC is a 64 bit value composed of two pieces:-* A "tag", of width `UNIQUE_TAG_BITS`, in the high order bits-* A number, of width `uNIQUE_BITS`, which fills up the remainder of the Word64+A `Unique` in GHC is a Word-sized value composed of two pieces:+* A "mask", of width `UNIQUE_TAG_BITS`, in the high order bits+* A number, of width `uNIQUE_BITS`, which fills up the remainder of the Word -The tag is typically an ASCII character.  It is typically used to make it easier+The mask is typically an ASCII character.  It is typically used to make it easier to distinguish uniques constructed by different parts of the compiler.-There is a (potentially incomplete) list of unique tags used given in-GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known tags]+There is a (potentially incomplete) list of unique masks used given in+GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known masks]  `mkUnique` constructs a `Unique` from its pieces-  mkUnique :: Char -> Word64 -> Unique+  mkUnique :: Char -> Int -> Unique  -} @@ -95,24 +91,24 @@ -- the functions from the 'UniqSupply' module -- -- These are sometimes also referred to as \"keys\" in comments in GHC.-newtype Unique = MkUnique Word64+newtype Unique = MkUnique Int  {-# INLINE uNIQUE_BITS #-} uNIQUE_BITS :: Int-uNIQUE_BITS = 64 - UNIQUE_TAG_BITS+uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS  {- Now come the functions which construct uniques from their pieces, and vice versa. The stuff about unique *supplies* is handled further down this module. -} -unpkUnique      :: Unique -> (Char, Word64)        -- The reverse+unpkUnique      :: Unique -> (Char, Int)        -- The reverse -mkUniqueGrimily :: Word64 -> Unique                -- A trap-door for UniqSupply-getKey          :: Unique -> Word64                -- for Var+mkUniqueGrimily :: Int -> Unique                -- A trap-door for UniqSupply+getKey          :: Unique -> Int                -- for Var  incrUnique   :: Unique -> Unique-stepUnique   :: Unique -> Word64 -> Unique+stepUnique   :: Unique -> Int -> Unique newTagUnique :: Unique -> Char -> Unique  mkUniqueGrimily = MkUnique@@ -123,7 +119,7 @@ incrUnique (MkUnique i) = MkUnique (i + 1) stepUnique (MkUnique i) n = MkUnique (i + n) -mkLocalUnique :: Word64 -> Unique+mkLocalUnique :: Int -> Unique mkLocalUnique i = mkUnique 'X' i  minLocalUnique :: Unique@@ -135,42 +131,30 @@ -- newTagUnique changes the "domain" of a unique to a different char newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u --- | Bitmask that has zeros for the tag bits and ones for the rest.-uniqueMask :: Word64+-- | How many bits are devoted to the unique index (as opposed to the class+-- character).+uniqueMask :: Int uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 --- | Put the character in the highest bits of the Word64.--- This may truncate the character to UNIQUE_TAG_BITS.--- This function is used in @`mkSplitUniqSupply`@ so that it can--- precompute and share the tag part of the uniques it generates.-mkTag :: Char -> Word64-mkTag c = intToWord64 (ord c) `shiftL` uNIQUE_BITS- -- pop the Char in the top 8 bits of the Unique(Supply)  -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM  -- and as long as the Char fits in 8 bits, which we assume anyway! -mkUnique :: Char -> Word64 -> Unique       -- Builds a unique from pieces+mkUnique :: Char -> Int -> Unique       -- Builds a unique from pieces -- EXPORTED and used only in GHC.Builtin.Uniques mkUnique c i   = MkUnique (tag .|. bits)   where-    tag  = mkTag c+    tag  = ord c `shiftL` uNIQUE_BITS     bits = i .&. uniqueMask -mkUniqueInt :: Char -> Int -> Unique-mkUniqueInt c i = mkUnique c (intToWord64 i)--mkUniqueIntGrimily :: Int -> Unique-mkUniqueIntGrimily = MkUnique . intToWord64- unpkUnique (MkUnique u)   = let-        -- The potentially truncating use of fromIntegral here is safe-        -- because the argument is just the tag bits after shifting.-        tag = chr (word64ToInt (u `shiftR` uNIQUE_BITS))+        -- as long as the Char may have its eighth bit set, we+        -- really do need the logical right-shift here!+        tag = chr (u `shiftR` uNIQUE_BITS)         i   = u .&. uniqueMask     in     (tag, i)@@ -200,10 +184,10 @@ x `hasKey` k    = getUnique x == k  instance Uniquable FastString where- getUnique fs = mkUniqueIntGrimily (uniqueOfFS fs)+ getUnique fs = mkUniqueGrimily (uniqueOfFS fs)  instance Uniquable Int where-  getUnique i = mkUniqueIntGrimily i+ getUnique i = mkUniqueGrimily i  instance Uniquable ModuleName where   getUnique (ModuleName nm) = getUnique nm@@ -277,7 +261,7 @@    1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which   2) Create a newtype wrapper based on Unique ordering where nondeterminism-     is controlled. See GHC.Unit.Module.Env.ModuleEnv+     is controlled. See Module.ModuleEnv   3) Change the algorithm to use nonDetCmpUnique and document why it's still      deterministic   4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel@@ -295,7 +279,7 @@ showUnique :: Unique -> String showUnique uniq   = case unpkUnique uniq of-      (tag, u) -> tag : w64ToBase62 u+      (tag, u) -> tag : iToBase62 u  pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques@@ -321,20 +305,19 @@ ************************************************************************  A character-stingy way to read/write numbers (notably Uniques).-The ``62-its'' are \tr{[0-9a-zA-Z]}.+The ``62-its'' are \tr{[0-9a-zA-Z]}.  We don't handle negative Ints. Code stolen from Lennart. -} -w64ToBase62 :: Word64 -> String-w64ToBase62 n_ = go n_ ""+iToBase62 :: Int -> String+iToBase62 n_+  = assert (n_ >= 0) $ go n_ ""   where-    -- The potentially truncating uses of fromIntegral here are safe-    -- because the argument is guaranteed to be less than 62 in both cases.     go n cs | n < 62-            = let !c = chooseChar62 (word64ToInt n) in c : cs+            = let !c = chooseChar62 n in c : cs             | otherwise             = go q (c : cs) where (!q, r) = quotRem n 62-                                  !c = chooseChar62 (word64ToInt r)+                                  !c = chooseChar62 r      chooseChar62 :: Int -> Char     {-# INLINE chooseChar62 #-}
compiler/GHC/Types/Unique/DFM.hs view
@@ -71,18 +71,18 @@  import GHC.Prelude -import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily )+import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable -import qualified GHC.Data.Word64Map.Strict as MS-import qualified GHC.Data.Word64Map as M+import qualified Data.IntMap.Strict as MS+import qualified Data.IntMap as M import Data.Data import Data.Functor.Classes (Eq1 (..)) import Data.List (sortBy) import Data.Function (on) import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) import Unsafe.Coerce-import qualified GHC.Data.Word64Set as W+import qualified Data.IntSet as I  -- Note [Deterministic UniqFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -94,7 +94,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. --@@ -147,7 +147,7 @@ -- very much discouraged. data UniqDFM key ele =   UDFM-    !(M.Word64Map (TaggedVal ele)) -- A map where keys are Unique's values and+    !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and                                 -- values are tagged with insertion time.                                 -- The invariant is that all the tags will                                 -- be distinct within a single map@@ -290,8 +290,6 @@ -- | Performs a deterministic fold over the UniqDFM. -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a-{-# INLINE foldUDFM #-}--- This INLINE prevents a regression in !10568 foldUDFM k z m = foldr k z (eltsUDFM m)  -- | Performs a nondeterministic strict fold over the UniqDFM.@@ -308,7 +306,7 @@ -- The INLINE makes it a good producer (from the map) eltsUDFM (UDFM m _i) = map taggedFst (sort_it m) -sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt]+sort_it :: M.IntMap (TaggedVal elt) -> [TaggedVal elt] sort_it m = sortBy (compare `on` taggedSnd) (M.elems m)  filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt@@ -317,12 +315,12 @@ filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i   where-  p' k (TaggedVal v _) = p (mkUniqueGrimily k) v+  p' k (TaggedVal v _) = p (getUnique k) v  udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i -udfmRestrictKeysSet :: UniqDFM key elt -> W.Word64Set -> UniqDFM key elt+udfmRestrictKeysSet :: UniqDFM key elt -> I.IntSet -> UniqDFM key elt udfmRestrictKeysSet (UDFM val_set i) set =   let key_set = set   in UDFM (M.restrictKeys val_set key_set) i@@ -331,7 +329,7 @@ -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). udfmToList :: UniqDFM key elt -> [(Unique, elt)] udfmToList (UDFM m _i) =-  [ (mkUniqueGrimily k, taggedFst v)+  [ (getUnique k, taggedFst v)   | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]  -- Determines whether two 'UniqDFM's contain the same keys.
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,12 @@         intersectUFM_C,         disjointUFM,         equalKeysUFM,-        nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM,+        nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM,+        nonDetFoldWithKeyUFM,         nonDetStrictFoldUFM_Directly,         anyUFM, allUFM, seqEltsUFM,-        mapUFM, mapUFM_Directly,-        mapMaybeUFM,+        mapUFM, mapUFM_Directly, strictMapUFM,+        mapMaybeUFM, mapMaybeWithKeyUFM,         elemUFM, elemUFM_Directly,         filterUFM, filterUFM_Directly, partitionUFM,         sizeUFM,@@ -84,12 +86,12 @@  import GHC.Prelude -import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily )+import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain-import qualified GHC.Data.Word64Map as M-import qualified GHC.Data.Word64Map.Strict as MS-import qualified GHC.Data.Word64Set as S+import qualified Data.IntMap as M+import qualified Data.IntMap.Strict as MS+import qualified Data.IntSet as S import Data.Data import qualified Data.Semigroup as Semi import Data.Functor.Classes (Eq1 (..))@@ -103,7 +105,7 @@ -- If two types don't overlap in their uniques it's also safe -- to index the same map at multiple key types. But this is -- very much discouraged.-newtype UniqFM key ele = UFM (M.Word64Map ele)+newtype UniqFM key ele = UFM (M.IntMap ele)   deriving (Data, Eq, Functor)   -- Nondeterministic Foldable and Traversable instances are accessible through   -- use of the 'NonDetUniqFM' wrapper.@@ -165,10 +167,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 +179,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 +190,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 +205,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@@ -323,6 +332,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,23 +368,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 (getUnique 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) +mapMaybeWithKeyUFM :: (Unique -> elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2+mapMaybeWithKeyUFM f (UFM m) = UFM (M.mapMaybeWithKey (f . getUnique) m)+ mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2-mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . mkUniqueGrimily) m)+mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) 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)  filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM key elt -> UniqFM key elt-filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . mkUniqueGrimily) m)+filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)  partitionUFM :: (elt -> Bool) -> UniqFM key elt -> (UniqFM key elt, UniqFM key elt) partitionUFM p (UFM m) =@@ -401,7 +429,7 @@ lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m -ufmToSet_Directly :: UniqFM key elt -> S.Word64Set+ufmToSet_Directly :: UniqFM key elt -> S.IntSet ufmToSet_Directly (UFM m) = M.keysSet m  anyUFM :: (elt -> Bool) -> UniqFM key elt -> Bool@@ -411,7 +439,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@@ -423,7 +451,7 @@ -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetKeysUFM :: UniqFM key elt -> [Unique]-nonDetKeysUFM (UFM m) = map mkUniqueGrimily $ M.keys m+nonDetKeysUFM (UFM m) = map getUnique $ M.keys m  -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce@@ -440,18 +468,18 @@ nonDetStrictFoldUFM_DirectlyM :: (Monad m) => (Unique -> b -> elt -> m b) -> b -> UniqFM key elt -> m b nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0   -- See Note [List fusion and continuations in 'c']-  where c u x k z = f (mkUniqueGrimily u) z x >>= k+  where c u x k z = f (getUnique u) z x >>= k         {-# INLINE c #-}  nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a-nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (mkUniqueGrimily i) x z') z m+nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m {-# INLINE nonDetStrictFoldUFM_Directly #-}  -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetUFMToList :: UniqFM key elt -> [(Unique, elt)]-nonDetUFMToList (UFM m) = map (\(k, v) -> (mkUniqueGrimily k, v)) $ M.toList m+nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m  -- | A wrapper around 'UniqFM' with the sole purpose of informing call sites -- that the provided 'Foldable' and 'Traversable' instances are@@ -476,10 +504,10 @@ instance forall key. Traversable (NonDetUniqFM key) where   traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m -ufmToIntMap :: UniqFM key elt -> M.Word64Map elt+ufmToIntMap :: UniqFM key elt -> M.IntMap elt ufmToIntMap (UFM m) = m -unsafeIntMapToUFM :: M.Word64Map elt -> UniqFM key elt+unsafeIntMapToUFM :: M.IntMap elt -> UniqFM key elt unsafeIntMapToUFM = UFM  -- | Cast the key domain of a UniqFM.
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
@@ -72,7 +72,7 @@ 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  addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a@@ -186,7 +186,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
compiler/GHC/Types/Unique/Supply.hs view
@@ -15,7 +15,7 @@          -- ** Operations on supplies         uniqFromSupply, uniqsFromSupply, -- basic ops-        takeUniqFromSupply, uniqFromTag,+        takeUniqFromSupply, uniqFromMask,          mkSplitUniqSupply,         splitUniqSupply, listSplitUniqSupply,@@ -39,19 +39,12 @@  import GHC.Utils.Monad import Control.Monad-import Data.Word+import Data.Char import GHC.Exts( Ptr(..), noDuplicate#, oneShot )-import Foreign.Storable--#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# )-#endif+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# ) #endif+import Foreign.Storable  #include "Unique.h" @@ -68,17 +61,17 @@ The basic idea (due to Lennart Augustsson) is that a UniqSupply is lazily-evaluated infinite tree. -* At each MkSplitUniqSupply node is a unique Word64, and two+* At each MkSplitUniqSupply node is a unique Int, and two   sub-trees (see data UniqSupply)  * takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)-  returns the unique Word64 and one of the sub-trees+  returns the unique Int and one of the sub-trees  * splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)   returns the two sub-trees  * When you poke on one of the thunks, it does a foreign call-  to get a fresh Word64 from a thread-safe counter, and returns+  to get a fresh Int from a thread-safe counter, and returns   a fresh MkSplitUniqSupply node.  This has to be as efficient   as possible: it should allocate only      * The fresh node@@ -90,25 +83,25 @@  * For creating new uniques either a UniqSupply is used and threaded through   or for monadic code a MonadUnique instance might conjure up uniques using-  `uniqFromTag`.+  `uniqFromMask`. * Different parts of the compiler will use a UniqSupply or MonadUnique instance-  with a specific tag. This way the different parts of the compiler will-  generate uniques with different tags.+  with a specific mask. This way the different parts of the compiler will+  generate uniques with different masks. -If different code shares the same tag then care has to be taken that all uniques+If different code shares the same mask then care has to be taken that all uniques still get distinct numbers. Usually this is done by relying on genSym which has *one* counter per GHC invocation that is relied on by all calls to it. But using something like the address for pinned objects works as well and in fact is done for fast strings.  This is important for example in the simplifier. Most passes of the simplifier use-the same tag 's'. However in some places we create a unique supply using `mkSplitUniqSupply`+the same mask 's'. However in some places we create a unique supply using `mkSplitUniqSupply` and thread it through the code, while in GHC.Core.Opt.Simplify.Monad  we use the `instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM-and `uniqFromTag` in getUniqueM.+and `uniqFromMask` in getUniqueM. -Ultimately all these boil down to each new unique consisting of the tag and the result from-a call to `genSym`. The latter producing a distinct number for each invocation ensuring+Ultimately all these boil down to each new unique consisting of the mask and the result from+a call to `genSym`. The later producing a distinct number for each invocation ensuring uniques are distinct.  Note [Optimising the unique supply]@@ -120,7 +113,7 @@         case unIO genSym s1 of { (# s2, u #) ->         case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->         case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->-        (# s4, MkSplitUniqSupply (tag .|. u) x y #)+        (# s4, MkSplitUniqSupply (mask .|. u) x y #)         }}}}  It's a classic example of an IO action that is captured and then called@@ -134,7 +127,7 @@                  genSym      >>= \ u ->                  mk_supply   >>= \ s1 ->                  mk_supply   >>= \ s2 ->-                 return (MkSplitUniqSupply (tag .|. u) s1 s2)+                 return (MkSplitUniqSupply (mask .|. u) s1 s2)  and to rely on -fno-state-hack, full laziness and inlining to get the same result. It was very brittle and required enabling -fno-state-hack globally. So@@ -153,29 +146,29 @@ get around the need to allocate one `UniqSupply` for each Unique we need. -For code in IO we can improve on this by threading only the *tag*-we are going to use for Uniques. Using `uniqFromTag` to+For code in IO we can improve on this by threading only the *mask*+we are going to use for Uniques. Using `uniqFromMask` to generate uniques as needed. This gets rid of the overhead of allocating a new UniqSupply for each unique generated. It also avoids-frequent state updates when the Unique/Tag is part of the state in a+frequent state updates when the Unique/Mask is part of the state in a state monad. -For monadic code in IO which always uses the same tag we can go further-and hardcode the tag into the MonadUnique instance. On top of all the-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].+For monadic code in IO which always uses the same mask we can go further+and hardcode the mask into the MonadUnique instance. On top of all the+benefits of threading the mask this *also* has the benefit of avoiding+the mask getting captured in thunks, or being passed around at runtime.+It does however come at the cost of having to use a fixed Mask for all+code run in this Monad. But remember, the Mask is purely cosmetic:+See Note [Uniques and masks].  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+IORef instead of the mask. While this would avoid frequent state updates it still requires allocating one UniqSupply per Unique. On top of some overhead for reading/writing to/from the IORef.  All of this hinges on the assumption that UniqSupply and-uniqFromTag use the same source of distinct numbers (`genSym`) which-allows both to be used at the same time, with the same tag, while still+uniqFromMask use the same source of distinct numbers (`genSym`) which+allows both to be used at the same time, with the same mask, while still ensuring distinct uniques. One might consider this fact to be an "accident". But GHC worked like this as far back as source control history goes. It also allows the later two@@ -191,18 +184,18 @@ -- also manufacture an arbitrary number of further 'UniqueSupply' values, -- which will be distinct from the first and from all others. data UniqSupply-  = MkSplitUniqSupply {-# UNPACK #-} !Word64 -- make the Unique with this+  = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this                    UniqSupply UniqSupply                                 -- when split => these two supplies  mkSplitUniqSupply :: Char -> IO UniqSupply -- ^ Create a unique supply out of thin air.--- The "tag" (Char) supplied is purely cosmetic, making it easier+-- The "mask" (Char) supplied is purely cosmetic, making it easier -- to figure out where a Unique was born. See--- Note [Uniques and tags].+-- Note [Uniques and masks]. -- -- The payload part of the Uniques allocated from this UniqSupply are--- guaranteed distinct wrt all other supplies, regardless of their "tag".+-- guaranteed distinct wrt all other supplies, regardless of their "mask". -- This is achieved by allocating the payload part from -- a single source of Uniques, namely `genSym`, shared across -- all UniqSupply's.@@ -213,7 +206,7 @@   = unsafeDupableInterleaveIO (IO mk_supply)    where-     !tag = mkTag c+     !mask = ord c `unsafeShiftL` uNIQUE_BITS          -- Here comes THE MAGIC: see Note [How the unique supply works]         -- This is one of the most hammered bits in the whole compiler@@ -225,28 +218,21 @@         -- deferred IO computations         case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->         case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->-        (# s4, MkSplitUniqSupply (tag .|. u) x y #)+        (# s4, MkSplitUniqSupply (mask .|. 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 !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int #else-genSym :: IO Word64+genSym :: IO Int genSym = do     let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1-    let !(Ptr counter) = ghc_unique_counter64+    let !(Ptr counter) = ghc_unique_counter     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             (# 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 = I# (word2Int# (val `plusWord#` inc)) .&. mask                 in (# s2, u #) #if defined(DEBUG)     -- Uh oh! We will overflow next time a unique is requested.@@ -256,19 +242,19 @@     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+foreign import ccall unsafe "&ghc_unique_counter" ghc_unique_counter :: Ptr Word+foreign import ccall unsafe "&ghc_unique_inc"     ghc_unique_inc     :: Ptr Int -initUniqSupply :: Word64 -> Int -> IO ()+initUniqSupply :: Word -> Int -> IO () initUniqSupply counter inc = do-    poke ghc_unique_counter64 counter-    poke ghc_unique_inc       inc+    poke ghc_unique_counter counter+    poke ghc_unique_inc     inc -uniqFromTag :: Char -> IO Unique-uniqFromTag !tag+uniqFromMask :: Char -> IO Unique+uniqFromMask !mask   = do { uqNum <- genSym-       ; return $! mkUnique tag uqNum }-{-# NOINLINE uniqFromTag #-} -- We'll unbox everything, but we don't want to inline it+       ; return $! mkUnique mask uqNum }+{-# NOINLINE uniqFromMask #-} -- We'll unbox everything, but we don't want to inline it  splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which
compiler/GHC/Types/Var.hs view
@@ -117,7 +117,7 @@ import {-# SOURCE #-}   GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique-                        , nonDetCmpUnique )+                        , mkUniqueGrimily, nonDetCmpUnique ) import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Utils.Misc import GHC.Utils.Binary@@ -247,7 +247,7 @@   = TyVar {  -- Type and kind variables              -- see Note [Kind and type variables]         varName    :: !Name,-        realUnique :: {-# UNPACK #-} !Unique,+        realUnique :: {-# UNPACK #-} !Int,                                      -- ^ Key for fast comparison                                      -- Identical to the Unique in the name,                                      -- cached here for speed@@ -258,14 +258,14 @@                                         -- Used for kind variables during                                         -- inference, as well         varName        :: !Name,-        realUnique     :: {-# UNPACK #-} !Unique,+        realUnique     :: {-# UNPACK #-} !Int,         varType        :: Kind,         tc_tv_details  :: TcTyVarDetails   }    | Id {         varName    :: !Name,-        realUnique :: {-# UNPACK #-} !Unique,+        realUnique :: {-# UNPACK #-} !Int,         varType    :: Type,         varMult    :: Mult,             -- See Note [Multiplicity of let binders]         idScope    :: IdScope,@@ -374,10 +374,10 @@     a == b = realUnique a == realUnique b  instance Ord Var where-    a <= b = getKey (realUnique a) <= getKey (realUnique b)-    a <  b = getKey (realUnique a) <  getKey (realUnique b)-    a >= b = getKey (realUnique a) >= getKey (realUnique b)-    a >  b = getKey (realUnique a) >  getKey (realUnique b)+    a <= b = realUnique a <= realUnique b+    a <  b = realUnique a <  realUnique b+    a >= b = realUnique a >= realUnique b+    a >  b = realUnique a >  realUnique b     a `compare` b = a `nonDetCmpVar` b  -- | Compare Vars by their Uniques.@@ -397,7 +397,7 @@   occName = nameOccName . varName  varUnique :: Var -> Unique-varUnique var = realUnique var+varUnique var = mkUniqueGrimily (realUnique var)  varMultMaybe :: Id -> Maybe Mult varMultMaybe (Id { varMult = mult }) = Just mult@@ -405,12 +405,12 @@  setVarUnique :: Var -> Unique -> Var setVarUnique var uniq-  = var { realUnique = uniq,+  = var { realUnique = getKey uniq,           varName = setNameUnique (varName var) uniq }  setVarName :: Var -> Name -> Var setVarName var new_name-  = var { realUnique = getUnique new_name,+  = var { realUnique = getKey (getUnique new_name),           varName = new_name }  setVarType :: Var -> Type -> Var@@ -687,10 +687,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@@ -1084,7 +1080,7 @@  mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = TyVar { varName    = name-                          , realUnique = nameUnique name+                          , realUnique = getKey (nameUnique name)                           , varType  = kind                           } @@ -1092,7 +1088,7 @@ mkTcTyVar name kind details   = -- NB: 'kind' may be a coercion kind; cf, 'GHC.Tc.Utils.TcMType.newMetaCoVar'     TcTyVar {   varName    = name,-                realUnique = nameUnique name,+                realUnique = getKey (nameUnique name),                 varType  = kind,                 tc_tv_details = details         }@@ -1148,7 +1144,7 @@ mk_id :: Name -> Mult -> Type -> IdScope -> IdDetails -> IdInfo -> Id mk_id name !w ty scope details info   = Id { varName    = name,-         realUnique = nameUnique name,+         realUnique = getKey (nameUnique name),          varMult    = w,          varType    = ty,          idScope    = scope,
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,@@ -77,7 +78,7 @@     ) where  import GHC.Prelude-import qualified GHC.Data.Word64Map.Strict as Word64Map -- TODO: Move this to UniqFM+import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM  import GHC.Types.Name.Occurrence import GHC.Types.Name@@ -227,7 +228,7 @@ -- introduce non-unique 'Unique's this way. See Note [Local uniques]. unsafeGetFreshLocalUnique :: InScopeSet -> Unique unsafeGetFreshLocalUnique (InScope set)-  | Just (uniq,_) <- Word64Map.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)+  | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)   , let uniq' = mkLocalUnique uniq   , not $ uniq' `ltUnique` minLocalUnique   = incrUnique uniq'@@ -318,25 +319,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@@ -530,6 +536,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@@ -565,6 +572,7 @@ isEmptyVarEnv    = isNullUFM partitionVarEnv  = partitionUFM varEnvDomain     = domUFMUnVarSet+nonDetStrictFoldVarEnv_Directly = nonDetStrictFoldUFM_Directly   restrictVarEnv env vs = filterUFM_Directly keep env
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
@@ -78,7 +78,7 @@ 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
compiler/GHC/Unit/Finder/Types.hs view
@@ -61,7 +61,7 @@                                            --   but the *unit* is hidden          -- | Module is in these units, but it is unusable-      , fr_unusables   :: [UnusableUnit]+      , fr_unusables   :: [(Unit, UnusableUnitReason)]        , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules       }
compiler/GHC/Unit/Module/Deps.hs view
@@ -21,6 +21,8 @@  import GHC.Prelude +import GHC.Data.FastString+ import GHC.Types.SafeHaskell import GHC.Types.Name @@ -275,7 +277,7 @@   -- | 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,
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
@@ -22,6 +22,7 @@    , showModMsg    , moduleGraphNodeModule    , moduleGraphNodeModSum+   , moduleGraphModulesBelow     , moduleGraphNodes    , SummaryNode@@ -50,7 +51,7 @@ import GHC.Data.Graph.Directed  import GHC.Driver.Backend-import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Types.SourceFile ( hscSourceString ) @@ -62,12 +63,14 @@ import qualified Data.Map as Map import GHC.Types.Unique.DSet import qualified Data.Set as Set+import Data.Set (Set) import GHC.Unit.Module import GHC.Linker.Static.Utils  import Data.Bifunctor import Data.Either import Data.Function+import Data.List (sort) import GHC.Data.List.SetOps  -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.@@ -385,3 +388,30 @@  type ModNodeKey = ModuleNameWithIsBoot ++-- | This function returns all the modules belonging to the home-unit that can+-- be reached by following the given dependencies. Additionally, if both the+-- boot module and the non-boot module can be reached, it only returns the+-- non-boot one.+moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid+moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <- modules_below]+  where+    td_map = mgTransDeps mg++    modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map++    filtered_mods = Set.fromDistinctAscList . filter_mods . sort++    -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list+    -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a+    -- linear sweep with a window of size 2 to remove boot modules for which we+    -- have the corresponding non-boot.+    filter_mods = \case+      (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)+        | m1 == m2  && uid1 == uid2 ->+                       let !r' = case b1 of+                                  NotBoot -> r1+                                  IsBoot  -> r2+                       in r' : filter_mods rs+        | otherwise -> r1 : filter_mods (r2:rs)+      rs -> rs
compiler/GHC/Unit/Module/ModIface.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NamedFieldPuns #-}  module GHC.Unit.Module.ModIface    ( ModIface@@ -109,8 +110,10 @@     -- 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_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))+    -- ^ Cached lookup for 'mi_warns' for declaration deprecations+  , mi_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn))+    -- ^ Cached lookup for 'mi_warns' for export deprecations   , mi_fix_fn :: !(OccName -> Maybe Fixity)     -- ^ Cached lookup for 'mi_fixities'   , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))@@ -184,7 +187,7 @@                 -- ^ Fixities                 -- NOT STRICT!  we read this field lazily from the interface file -        mi_warns    :: (Warnings GhcRn),+        mi_warns    :: IfaceWarnings,                 -- ^ Warnings                 -- NOT STRICT!  we read this field lazily from the interface file @@ -205,7 +208,7 @@                 -- 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),+        mi_globals  :: !(Maybe IfGlobalRdrEnv),                 -- ^ 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@@ -478,7 +481,8 @@                    mi_finsts = hasFamInsts,                    mi_exp_hash = exp_hash,                    mi_orphan_hash = orphan_hash,-                   mi_warn_fn = mkIfaceWarnCache warns,+                   mi_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns,+                   mi_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns,                    mi_fix_fn = mkIfaceFixCache fixities,                    mi_hash_fn = mkIfaceHashCache decls                  }})@@ -497,7 +501,7 @@                mi_exports     = [],                mi_used_th     = False,                mi_fixities    = [],-               mi_warns       = NoWarnings,+               mi_warns       = IfWarnSome [] [],                mi_anns        = [],                mi_insts       = [],                mi_fam_insts   = [],@@ -529,7 +533,8 @@           mi_finsts = False,           mi_exp_hash = fingerprint0,           mi_orphan_hash = fingerprint0,-          mi_warn_fn = emptyIfaceWarnCache,+          mi_decl_warn_fn = emptyIfaceWarnCache,+          mi_export_warn_fn = emptyIfaceWarnCache,           mi_fix_fn = emptyIfaceFixCache,           mi_hash_fn = emptyIfaceHashCache } } @@ -549,20 +554,64 @@  -- 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+instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))+         , NFData (IfaceDeclExts (phase :: ModIfacePhase))+         ) => NFData (ModIface_ phase) where+  rnf (ModIface{ mi_module, mi_sig_of, mi_hsc_src, mi_deps, mi_usages+               , mi_exports, mi_used_th, mi_fixities, mi_warns, mi_anns+               , mi_decls, mi_extra_decls, mi_globals, mi_insts+               , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg+               , mi_complete_matches, mi_docs, mi_final_exts+               , mi_ext_fields, mi_src_hash })+    =     rnf mi_module+    `seq` rnf mi_sig_of+    `seq`     mi_hsc_src+    `seq`     mi_deps+    `seq`     mi_usages+    `seq`     mi_exports+    `seq` rnf mi_used_th+    `seq`     mi_fixities+    `seq` rnf mi_warns+    `seq` rnf mi_anns+    `seq` rnf mi_decls+    `seq` rnf mi_extra_decls+    `seq`     mi_globals+    -- NB: we already removed any potential space leaks in 'mi_globals' by+    -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'.+    -- This means we don't need to use 'rnf' here.+    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+    `seq` rnf mi_insts+    `seq` rnf mi_fam_insts+    `seq` rnf mi_rules+    `seq` rnf mi_hpc+    `seq`     mi_trust+    `seq` rnf mi_trust_pkg+    `seq` rnf mi_complete_matches+    `seq` rnf mi_docs+    `seq`     mi_final_exts+    `seq`     mi_ext_fields+    `seq` rnf mi_src_hash     `seq` () - instance NFData (ModIfaceBackend) where-  rnf (ModIfaceBackend 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+  rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash+                      , mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash+                      , mi_orphan_hash, mi_decl_warn_fn, mi_export_warn_fn, mi_fix_fn+                      , mi_hash_fn})+    =     rnf mi_iface_hash+    `seq` rnf mi_mod_hash+    `seq` rnf mi_flag_hash+    `seq` rnf mi_opt_hash+    `seq` rnf mi_hpc_hash+    `seq` rnf mi_plugin_hash+    `seq` rnf mi_orphan+    `seq` rnf mi_finsts+    `seq` rnf mi_exp_hash+    `seq` rnf mi_orphan_hash+    `seq` rnf mi_decl_warn_fn+    `seq` rnf mi_export_warn_fn+    `seq` rnf mi_fix_fn+    `seq` rnf mi_hash_fn   forceModIface :: ModIface -> IO ()
compiler/GHC/Unit/Module/ModSummary.hs view
@@ -27,7 +27,7 @@  import GHC.Hs -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Unit.Types import GHC.Unit.Module
compiler/GHC/Unit/Module/Warnings.hs view
@@ -1,42 +1,205 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}  -- | 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 (..)+   , 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.Utils.Outputable import GHC.Utils.Binary+import GHC.Unicode +import Language.Haskell.Syntax.Concrete (HsToken (HsTok)) 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 :: !(Located (HsToken "in")),+      iwc_st :: !SourceText,+      iwc_wc :: (Located WarningCategory)+    } deriving Data++fromWarningCategory :: WarningCategory -> InWarningCategory+fromWarningCategory wc = InWarningCategory (noLoc HsTok) NoSourceText (noLoc wc)+++-- See Note [Warning categories]+newtype WarningCategory = WarningCategory FastString+  deriving (Binary, Data, 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)++ -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt pass    = WarningTxt+      (Maybe (Located InWarningCategory))+        -- ^ Warning category attached to this WARNING pragma, if any;+        -- see Note [Warning categories]       (Located SourceText)       [Located (WithHsDocIdentifiers StringLiteral pass)]    | DeprecatedTxt@@ -44,40 +207,52 @@       [Located (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 -> [Located (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 (HsToken "in"), Eq (IdP pass)) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) +instance Outputable InWarningCategory where+  ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt)++ instance Outputable (WarningTxt pass) where-    ppr (WarningTxt    lsrc ws)+    ppr (WarningTxt mcat lsrc ws)       = case unLoc lsrc of-          NoSourceText   -> pp_ws ws-          SourceText src -> text src <+> pp_ws ws <+> text "#-}"+            NoSourceText   -> pp_ws ws+            SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"+        where+          ctg_doc = maybe empty (\ctg -> ppr ctg) mcat +     ppr (DeprecatedTxt lsrc  ds)       = case unLoc lsrc of           NoSourceText   -> pp_ws ds-          SourceText src -> text src <+> pp_ws ds <+> text "#-}"--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)-+          SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"  pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l@@ -88,20 +263,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 +296,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/State.hs view
@@ -43,7 +43,6 @@         LookupResult(..),         ModuleSuggestion(..),         ModuleOrigin(..),-        UnusableUnit(..),         UnusableUnitReason(..),         pprReason, @@ -76,7 +75,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Platform import GHC.Platform.Ways@@ -92,6 +91,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,13 +112,10 @@ 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@@ -175,10 +173,8 @@     -- (But maybe the user didn't realize), so we'll still keep track     -- of these modules.)     ModHidden--    -- | Module is unavailable because the unit is unusable.-  | ModUnusable !UnusableUnit-+    -- | Module is unavailable because the package is unusable.+  | ModUnusable UnusableUnitReason     -- | Module is public, and could have come from some places.   | ModOrigin {         -- | @Just False@ means that this module is in@@ -196,13 +192,6 @@       , fromPackageFlag :: Bool       } --- | A unusable unit module origin-data UnusableUnit = UnusableUnit-  { uuUnit        :: !Unit               -- ^ Unusable unit-  , uuReason      :: !UnusableUnitReason -- ^ Reason-  , uuIsReexport  :: !Bool               -- ^ Is the "module" a reexport?-  }- instance Outputable ModuleOrigin where     ppr ModHidden = text "hidden module"     ppr (ModUnusable _) = text "unusable module"@@ -247,8 +236,7 @@                     text "x: " <> ppr x $$ text "y: " <> ppr y             g Nothing x = x             g x Nothing = x--    x <> y = pprPanic "ModOrigin: module origin mismatch" $+    x <> y = pprPanic "ModOrigin: hidden module redefined" $                  text "x: " <> ppr x $$ text "y: " <> ppr y  instance Monoid ModuleOrigin where@@ -271,7 +259,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 +273,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 +297,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 +306,7 @@              { uv_expose_all = False              , uv_renamings = []              , uv_package_name = First Nothing-             , uv_requirements = Map.empty+             , uv_requirements = emptyUniqMap              , uv_explicit = Nothing              }     mappend = (Semigroup.<>)@@ -418,7 +406,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 +430,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 +463,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 +474,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 +497,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 +513,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 +534,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 +568,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 +599,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 +902,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 +924,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 +948,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 +956,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 +972,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 +997,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 +1051,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 +1076,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 +1092,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 +1118,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 +1144,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 +1153,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 +1175,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 +1194,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 +1231,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 +1261,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 +1275,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 +1297,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 +1309,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 +1320,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 +1329,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 +1349,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 +1357,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 +1369,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 +1407,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 +1544,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 +1584,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 +1621,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 +1652,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 +1667,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 +1682,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 +1695,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 +1718,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 +1753,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 +1790,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 +1800,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,54 +1816,39 @@ -- | 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, (pkg, reason)) modmap = addListTo modmap bindings+      where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]             bindings = exposed ++ hidden -            origin_reexport =  ModUnusable (UnusableUnit unit reason True)-            origin_normal   =  ModUnusable (UnusableUnit unit reason False)-            unit = mkUnit unit_info+            origin = ModUnusable reason+            pkg_id = mkUnit pkg              exposed = map get_exposed exposed_mods-            hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods]+            hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] -            -- with re-exports, c:Foo can be reexported from two (or more)-            -- unusable packages:-            --  Foo -> a:Foo (unusable reason A) -> c:Foo-            --      -> b:Foo (unusable reason B) -> c:Foo-            ---            -- We must be careful to not record the following (#21097):-            --  Foo -> c:Foo (unusable reason A)-            --      -> c:Foo (unusable reason B)-            -- But:-            --  Foo -> a:Foo (unusable reason A)-            --      -> b:Foo (unusable reason B)-            ---            get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport)-            get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal)-              -- in the reexport case, we create a virtual module that doesn't-              -- exist but we don't care as it's only used as a key in the map.+            get_exposed (mod, Just mod') = (mod, unitUniqMap mod' origin)+            get_exposed (mod, _)         = (mod, mkModMap pkg_id mod origin) -            exposed_mods = unitExposedModules unit_info-            hidden_mods  = unitHiddenModules  unit_info+            exposed_mods = unitExposedModules pkg+            hidden_mods  = unitHiddenModules pkg  -- | Add a list of key/value pairs to a nested map. -- -- 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)   -- -----------------------------------------------------------------------------@@ -1950,10 +1926,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 +1987,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 +1996,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 +2008,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 +2019,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 +2031,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 +2076,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 +2131,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)
compiler/GHC/Unit/Types.hs view
@@ -99,6 +99,7 @@ import GHC.Utils.Encoding import GHC.Utils.Fingerprint import GHC.Utils.Misc+import GHC.Settings.Config (cProjectUnitId)  import Control.DeepSeq import Data.Data@@ -166,7 +167,7 @@ instance Outputable InstantiatedUnit where   ppr = pprInstantiatedUnit -pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc+pprInstantiatedUnit :: InstantiatedUnit -> SDoc pprInstantiatedUnit uid =       -- getPprStyle $ \sty ->       pprUnitId cid <>@@ -180,8 +181,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 +202,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)@@ -352,12 +350,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@@ -535,12 +531,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@@ -606,7 +598,7 @@ bignumUnitId      = UnitId (fsLit "ghc-bignum") baseUnitId        = UnitId (fsLit "base") 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") @@ -634,8 +626,49 @@    , baseUnitId    , 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
compiler/GHC/Utils/Binary.hs view
@@ -44,7 +44,7 @@    castBin,    withBinBuffer, -   foldGet,+   foldGet, foldGet',     writeBinMem,    readBinMem,@@ -332,7 +332,24 @@           b' <- f i a b           go (i+1) b' +foldGet'+  :: Binary a+  => Word -- n elements+  -> BinHandle+  -> 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 @@ -1242,16 +1259,6 @@ 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
− compiler/GHC/Utils/Containers/Internal/BitUtil.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Utils.Containers.Internal.BitUtil--- Copyright   :  (c) Clark Gaebel 2012---                (c) Johan Tibel 2012--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------------------------------------------------------------------------------------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ The contents of this module may change __in any way whatsoever__--- and __without any warning__ between minor versions of this package.------ Authors importing this module are expected to track development--- closely.--module GHC.Utils.Containers.Internal.BitUtil-    ( bitcount-    , highestBitMask-    , shiftLL-    , shiftRL-    ) where--import GHC.Prelude.Basic-import Data.Word--{-----------------------------------------------------------------------  [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,-  based on the code on-  http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan,-  where the following source is given:-    Published in 1988, the C Programming Language 2nd Ed. (by Brian W.-    Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April-    19, 2006 Don Knuth pointed out to me that this method "was first published-    by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by-    Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"-----------------------------------------------------------------------}--bitcount :: Int -> Word64 -> Int-bitcount a x = a + popCount x-{-# INLINE bitcount #-}---- The highestBitMask implementation is based on--- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2--- which has been put in the public domain.---- | Return a word where only the highest bit is set.-highestBitMask :: Word64 -> Word64-highestBitMask w = shiftLL 1 (63 - countLeadingZeros w)-{-# INLINE highestBitMask #-}---- Right and left logical shifts.-shiftRL, shiftLL :: Word64 -> Int -> Word64-shiftRL = unsafeShiftR-shiftLL = unsafeShiftL
− compiler/GHC/Utils/Containers/Internal/StrictPair.hs 
@@ -1,25 +0,0 @@-{-# 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---- | The same as a regular Haskell pair, but------ @--- (x :*: _|_) = (_|_ :*: y) = _|_--- @-data StrictPair a b = !a :*: !b--infixr 1 :*:---- | Convert a strict pair to a standard pair.-toPair :: StrictPair a b -> (a, b)-toPair (x :*: y) = (x, y)-{-# INLINE toPair #-}
compiler/GHC/Utils/Error.hs view
@@ -32,7 +32,7 @@         formatBulleted,          -- ** Construction-        DiagOpts (..), diag_wopt, diag_fatal_wopt,+        DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt,         emptyMessages, mkDecorated, mkLocMessage,         mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,         mkErrorMsgEnvelope,@@ -79,6 +79,7 @@ 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 +90,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 +187,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 +209,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 +222,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 +240,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 +268,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 +296,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
compiler/GHC/Utils/Lexeme.hs view
@@ -227,11 +227,10 @@                            , "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).+-- | All reserved operators. Taken from section 2.4 of the 2010 Report. reservedOps :: Set.Set String reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->"-                           , "=>" ]+                           , "@", "~", "=>" ]  -- | Does this string contain only dashes and has at least 2 of them? isDashes :: String -> Bool
compiler/GHC/Utils/Misc.hs view
@@ -22,7 +22,7 @@         unzipWith,          mapFst, mapSnd, chkAppend,-        mapAndUnzip, mapAndUnzip3,+        mapAndUnzip, mapAndUnzip3, mapAndUnzip4,         filterOut, partitionWith,          dropWhileEndLE, spanEnd, last2, lastMaybe, onJust,@@ -35,7 +35,7 @@         equalLength, compareLength, leLength, ltLength,          isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,-        notNull, snocView,+        notNull, expectNonEmpty, snocView,          chunkList, @@ -55,6 +55,7 @@          -- * Tuples         fstOf3, sndOf3, thdOf3,+        fstOf4, sndOf4,         fst3, snd3, third3,         uncurry3, @@ -121,6 +122,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,7 +131,6 @@  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 @@ -183,6 +184,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) @@ -324,7 +330,6 @@     (r1:rs1, r2:rs2)  mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])- mapAndUnzip3 _ [] = ([], [], []) mapAndUnzip3 f (x:xs)   = let (r1,  r2,  r3)  = f x@@ -332,6 +337,14 @@     in     (r1:rs1, r2:rs2, r3:rs3) +mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e])+mapAndUnzip4 _ [] = ([], [], [], [])+mapAndUnzip4 f (x:xs)+  = let (r1,  r2,  r3, r4)  = f x+        (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3, r4:rs4)+ zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip f (a:as) (b:bs)   = let (r1,  r2)  = f a b@@ -481,7 +494,6 @@ #endif expectOnly msg _     = panic ("expectOnly: " ++ msg) - -- | Split a list into chunks of /n/ elements chunkList :: Int -> [a] -> [[a]] chunkList _ [] = []@@ -499,6 +511,16 @@ changeLast []     _  = panic "changeLast" changeLast [_]    x  = [x] changeLast (x:xs) x' = x : changeLast xs x'++-- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'.+expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a+{-# INLINE expectNonEmpty #-}+expectNonEmpty _   (x:xs) = x:|xs+expectNonEmpty msg []     = expectNonEmptyPanic msg++expectNonEmptyPanic :: String -> a+expectNonEmptyPanic msg = panic ("expectNonEmpty: " ++ msg)+{-# NOINLINE expectNonEmptyPanic #-}  -- | Apply an effectful function to the last list element. mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a)
compiler/GHC/Utils/Monad.hs view
@@ -11,6 +11,7 @@         , MonadIO(..)          , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM+        , zipWith3MNE         , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M         , mapAccumLM         , mapSndM@@ -96,6 +97,15 @@        ; (cs, ds) <- zipWithAndUnzipM f xs ys        ; 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 }  {-
compiler/GHC/Utils/Outputable.hs view
@@ -31,12 +31,13 @@         SDoc, runSDoc, PDoc(..),         docToSDoc,         interppSP, interpp'SP, interpp'SP',-        pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,+        pprQuotedList, pprWithCommas,+        quotedListWithOr, quotedListWithNor, quotedListWithAnd,         pprWithBars,         spaceIfSingleQuote,         isEmpty, nest,         ptext,-        int, intWithCommas, integer, word64, word, float, double, rational, doublePrec,+        int, intWithCommas, integer, word, float, double, rational, doublePrec,         parens, cparen, brackets, braces, quotes, quote,         doubleQuotes, angleBrackets,         semi, comma, colon, dcolon, space, equals, dot, vbar,@@ -46,8 +47,8 @@         blankLine, forAllLit, bullet,         ($+$),         cat, fcat,-        hang, hangNotEmpty, punctuate, ppWhen, ppUnless,-        ppWhenOption, ppUnlessOption,+        hang, hangNotEmpty, punctuate, punctuateFinal,+        ppWhen, ppUnless, ppWhenOption, ppUnlessOption,         speakNth, speakN, speakNOf, plural, singular,         isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,         unicodeSyntax,@@ -126,6 +127,7 @@ 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 )@@ -139,7 +141,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set-import qualified GHC.Data.Word64Set as Word64Set+import qualified Data.IntSet as IntSet import Data.String import Data.Word import System.IO        ( Handle )@@ -149,8 +151,9 @@ 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 @@ -678,7 +681,6 @@ int      :: IsLine doc => Int        -> doc integer  :: IsLine doc => Integer    -> doc word     ::               Integer    -> SDoc-word64   :: IsLine doc => Word64     -> doc float    :: IsLine doc => Float      -> doc double   :: IsLine doc => Double     -> doc rational ::               Rational   -> SDoc@@ -696,8 +698,6 @@ {-# INLINE CONLIKE rational #-} rational n  = text $ show n               -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr-{-# INLINE CONLIKE word64 #-}-word64 n    = text $ show n {-# INLINE CONLIKE word #-} word n      = sdocOption sdocHexWordLiterals $ \case                True  -> docToSDoc $ Pretty.hex n@@ -842,6 +842,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 +873,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 +906,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,11 +969,14 @@ 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])@@ -1043,10 +1065,7 @@  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] @@ -1387,6 +1406,11 @@ 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+ {- ************************************************************************ *                                                                      *@@ -1636,6 +1660,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 +1697,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 +1737,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 +1746,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 +1817,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 +1866,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@@ -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
@@ -29,6 +29,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@@ -150,4 +152,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/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 
@@ -1,20 +0,0 @@-module GHC.Utils.Word64 (-    intToWord64,-    word64ToInt,-    truncateWord64ToWord32,-  ) where--import GHC.Prelude-import GHC.Utils.Panic.Plain (assert)--import Data.Word-import GHC.Stack--intToWord64 :: HasCallStack => Int -> Word64-intToWord64 x = assert (0 <= x) (fromIntegral x)--word64ToInt :: HasCallStack => Word64 -> Int-word64ToInt x = assert (x <= fromIntegral (maxBound :: Int)) (fromIntegral x)--truncateWord64ToWord32 :: Word64 -> Word32-truncateWord64ToWord32 = fromIntegral
compiler/Language/Haskell/Syntax/Concrete.hs view
@@ -35,6 +35,7 @@ -- avoid a dependency. data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok +deriving instance Eq (HsToken tok) deriving instance KnownSymbol tok => Data (HsToken tok) deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)
compiler/Language/Haskell/Syntax/Decls.hs view
@@ -30,7 +30,7 @@   HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..),   HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,   NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData,-  isTypeDataDefnCons,+  isTypeDataDefnCons, firstDataDefnCon,   StandaloneKindSig(..), LStandaloneKindSig,    -- ** Class or type declarations@@ -45,7 +45,7 @@   FamilyDecl(..), LFamilyDecl,    -- ** Instance declarations-  InstDecl(..), LInstDecl, FamilyInfo(..),+  InstDecl(..), LInstDecl, FamilyInfo(..), familyInfoTyConFlavour,   TyFamInstDecl(..), LTyFamInstDecl,   TyFamDefltDecl, LTyFamDefltDecl,   DataFamInstDecl(..), LDataFamInstDecl,@@ -99,12 +99,14 @@ import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Basic (Role) -import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation)+import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation+                       ,TyConFlavour(..), TypeOrData(..)) 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.Utils.Panic.Plain ( assert )  import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST @@ -580,7 +582,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 @@ -862,7 +865,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 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@@ -1015,6 +1040,11 @@ 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@@ -1598,7 +1628,7 @@        { 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"+           -- ^ Note [Pragma source text] in "GHC.Types.SourceText"        , rd_act  :: Activation        , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]            -- ^ Forall'd type vars
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]@@ -39,7 +40,6 @@ -- libraries: import Data.Data hiding (Fixity(..)) import Data.Bool-import Data.Either import Data.Eq import Data.Maybe import Data.List.NonEmpty ( NonEmpty )@@ -147,6 +147,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+ {- ************************************************************************ *                                                                      *@@ -463,7 +476,7 @@   | 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@@ -1587,11 +1600,11 @@  -- | 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+  = 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  -- | Haskell arrow match context. data HsArrowMatchContext
compiler/Language/Haskell/Syntax/Extension.hs view
@@ -432,6 +432,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@@ -566,7 +568,13 @@ 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
compiler/Language/Haskell/Syntax/ImpExp.hs view
@@ -127,7 +127,7 @@         -- ^ Imported or exported Thing With given imported or exported         --         -- The thing is a Class/Type and the imported or exported things are-        -- methods/constructors and record fields; see Note [IEThingWith]+        -- its children.         -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',         --                                   'GHC.Parser.Annotation.AnnClose',         --                                   'GHC.Parser.Annotation.AnnComma',
compiler/Language/Haskell/Syntax/Lit.hs view
@@ -42,9 +42,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@@ -63,8 +63,20 @@       -- ^ 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@@ -107,7 +119,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@@ -149,4 +161,3 @@   compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `lexicalCompareFS` s2   compare (HsIsString _ _)    (HsIntegral   _)    = GT   compare (HsIsString _ _)    (HsFractional _)    = GT-
compiler/Language/Haskell/Syntax/Pat.hs view
@@ -280,13 +280,13 @@ type LHsRecField  p arg = XRec p (HsRecField  p arg)  -- | Located Haskell Record Update Field-type LHsRecUpdField p   = XRec p (HsRecUpdField p)+type LHsRecUpdField p q = XRec p (HsRecUpdField p q)  -- | Haskell Record Field type HsRecField p arg   = HsFieldBind (LFieldOcc p) arg  -- | Haskell Record Update Field-type HsRecUpdField p    = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr p)+type HsRecUpdField p q  = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr q)  -- | Haskell Field Binding --@@ -353,7 +353,7 @@ -- --     hfbLHS = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id ----- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head.+-- See also Note [Disambiguating record updates] in GHC.Rename.Pat.  hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p] hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds)@@ -363,4 +363,3 @@  hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p hsRecFieldSel = foExt . unXRec @p . hfbLHS-
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@@ -25,6 +26,7 @@         HsLinearArrowTokens(..),          HsType(..), LHsType, HsKind, LHsKind,+        HsBndrVis(..), isHsBndrInvisible,         HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,         LHsQTyVars(..),         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,@@ -44,7 +46,7 @@          ConDeclField(..), LConDeclField, -        HsConDetails(..), noTypeArgs,+        HsConDetails(..), noTypeArgs, conDetailsArity,          FieldOcc(..), LFieldOcc,         AmbiguousFieldOcc(..), LAmbiguousFieldOcc,@@ -64,6 +66,7 @@ import GHC.Core.DataCon( HsSrcBang(..) ) import GHC.Core.Type (Specificity) import GHC.Types.SrcLoc (SrcSpan)+import GHC.Types.Basic (Arity)  import GHC.Hs.Doc (LHsDoc) import GHC.Data.FastString (FastString)@@ -74,7 +77,7 @@ import Data.Eq import Data.Bool import Data.Char-import Prelude (Integer)+import Prelude (Integer, length)  {- ************************************************************************@@ -342,12 +345,12 @@ 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 :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass] hsQTvExplicit = hsq_explicit  ------------------------------------------------@@ -713,6 +716,21 @@   | XTyVarBndr       !(XXTyVarBndr pass) +data HsBndrVis pass+  = HsBndrRequired+      -- Binder for a visible (required) variable:+      --     type Dup a = (a, a)+      --             ^^^++  | HsBndrInvisible (LHsToken "@" pass)+      -- Binder for an invisible (specified) variable:+      --     type KindOf @k (a :: k) = k+      --                ^^^++isHsBndrInvisible :: HsBndrVis pass -> Bool+isHsBndrInvisible HsBndrInvisible{} = True+isHsBndrInvisible HsBndrRequired    = False+ -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool isHsKindedTyVar (UserTyVar {})   = False@@ -756,6 +774,7 @@    | HsAppKindTy         (XAppKindTy pass) -- type level type app                         (LHsType pass)+                       !(LHsToken "@" pass)                         (LHsKind pass)    | HsFunTy             (XFunTy pass)@@ -1071,6 +1090,12 @@ noTypeArgs :: [Void] noTypeArgs = [] +conDetailsArity :: (rec -> Arity) -> HsConDetails tyarg arg rec -> Arity+conDetailsArity recToArity = \case+  PrefixCon _ args -> length args+  RecCon rec -> recToArity rec+  InfixCon _ _ -> 2+ {- Note [ConDeclField pass] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1181,14 +1206,13 @@ -}  -- | Arguments in an expression/type after splitting-data HsArg tm ty+data HsArg p 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 `@`+  | HsTypeArg !(LHsToken "@" p) ty -- Argument is a visible type application (f @ty)   | HsArgPar SrcSpan -- See Note [HsArgPar]  -- type level equivalent-type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)+type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p)  {- Note [HsArgPar]
compiler/cbits/genSym.c view
@@ -9,44 +9,16 @@ // // 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-#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)-// Unique64 patch was backported to 9.8.4-#define HAVE_UNIQUE64 1-#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)-// Unique64 patch was backported to 9.6.7-#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_counter = 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_BITS (sizeof (HsInt) * 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;+HsInt ghc_lib_parser_genSym(void) {+    HsInt u = atomic_inc((StgWord *)&ghc_unique_counter, ghc_unique_inc) & UNIQUE_MASK;     // Uh oh! We will overflow next time a unique is requested.     ASSERT(u != UNIQUE_MASK);     return u;
compiler/cbits/keepCAFsForGHCi.c view
@@ -1,7 +1,7 @@ #include <Rts.h> #include <ghcversion.h> -// Note [ghc_lib_parser_keepCAFsForGHCi]+// Note [keepCAFsForGHCi] // ~~~~~~~~~~~~~~~~~~~~~~ // This file is only included in the dynamic library. // It contains an __attribute__((constructor)) function (run prior to main())@@ -14,7 +14,7 @@ // an archive and not otherwise referenced the linker would ignore the object. // To avoid this: // * When initializing a GHC session in initGhcMonad we assert keeping cafs has been-//   enabled by calling ghc_lib_parser_keepCAFsForGHCi.+//   enabled by calling keepCAFsForGHCi. // * This causes the GHC module from the ghc package to carry a reference to this object //   file. // * Which in turn ensures the linker doesn't discard this object file, causing@@ -23,9 +23,9 @@   -bool ghc_lib_parser_keepCAFsForGHCi(void) __attribute__((constructor));+bool keepCAFsForGHCi(void) __attribute__((constructor)); -bool ghc_lib_parser_keepCAFsForGHCi(void)+bool keepCAFsForGHCi(void) {     bool was_set = keepCAFs;     setKeepCAFs();
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.8.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -25,7 +25,6 @@  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@@ -39,7 +38,7 @@   custom-setup-    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath+    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath, containers  Flag internal-interpreter     Description: Build with internal interpreter support.@@ -57,6 +56,20 @@     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+ Library     Default-Language: Haskell2010     Exposed: False@@ -71,24 +84,35 @@     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.20,+                   deepseq    >= 1.4 && < 1.6,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,-                   bytestring >= 0.9 && < 0.12,+                   bytestring >= 0.9 && < 0.13,                    binary     == 0.8.*,                    time       >= 1.4 && < 1.13,                    containers >= 0.6.2.1 && < 0.7,                    array      >= 0.1 && < 0.6,                    filepath   >= 1   && < 1.5,-                   template-haskell == 2.20.*,-                   hpc        == 0.6.*,+                   template-haskell == 2.21.*,+                   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+                   ghc-boot   == 9.8.1,+                   ghc-heap   == 9.8.1,+                   ghci == 9.8.1      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.14@@ -136,15 +160,12 @@      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:-        jsbits/genSym.js-    else-      c-sources:+    c-sources:         cbits/cutils.c         cbits/genSym.c         cbits/keepCAFsForGHCi.c@@ -307,6 +328,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 +344,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@@ -394,13 +417,6 @@         GHC.Data.TrieMap         GHC.Data.Unboxed         GHC.Data.UnionFind-        GHC.Data.Word64Set-        GHC.Data.Word64Set.Internal-        GHC.Data.Word64Map-        GHC.Data.Word64Map.Internal-        GHC.Data.Word64Map.Lazy-        GHC.Data.Word64Map.Strict-        GHC.Data.Word64Map.Strict.Internal         GHC.Driver.Backend         GHC.Driver.Backend.Internal         GHC.Driver.Backpack@@ -436,6 +452,7 @@         GHC.Driver.Config.StgToCmm         GHC.Driver.Config.Tidy         GHC.Driver.Config.StgToJS+        GHC.Driver.DynFlags         GHC.Driver.Env         GHC.Driver.Env.KnotVars         GHC.Driver.Env.Types@@ -446,6 +463,7 @@         GHC.Driver.GenerateCgIPEStub         GHC.Driver.Hooks         GHC.Driver.LlvmConfigCache+        GHC.Driver.MakeSem         GHC.Driver.Main         GHC.Driver.Make         GHC.Driver.MakeFile@@ -511,8 +529,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@@ -531,11 +552,14 @@         GHC.IfaceToCore         GHC.Iface.Type         GHC.JS.Make+        GHC.JS.Optimizer         GHC.JS.Ppr         GHC.JS.Syntax         GHC.JS.Transform+        GHC.JS.Unsat.Syntax         GHC.Linker         GHC.Linker.Config+        GHC.Linker.Deps         GHC.Linker.Dynamic         GHC.Linker.ExtraObj         GHC.Linker.Loader@@ -567,6 +591,7 @@         GHC.Platform.ARM         GHC.Platform.AArch64         GHC.Platform.Constants+        GHC.Platform.LoongArch64         GHC.Platform.NoRegs         GHC.Platform.PPC         GHC.Platform.Profile@@ -574,7 +599,6 @@         GHC.Platform.Reg.Class         GHC.Platform.Regs         GHC.Platform.RISCV64-        GHC.Platform.LoongArch64         GHC.Platform.S390X         GHC.Platform.Wasm32         GHC.Platform.Ways@@ -602,8 +626,11 @@         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.Loader+        GHC.Runtime.Utils         GHC.Settings         GHC.Settings.Config         GHC.Settings.Constants@@ -616,6 +643,7 @@         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@@ -656,7 +684,6 @@         GHC.StgToJS.Arg         GHC.StgToJS.Closure         GHC.StgToJS.CodeGen-        GHC.StgToJS.CoreUtils         GHC.StgToJS.DataCon         GHC.StgToJS.Deps         GHC.StgToJS.Expr@@ -669,20 +696,19 @@         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.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@@ -702,8 +728,10 @@         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@@ -726,10 +754,12 @@         GHC.Tc.Module         GHC.Tc.Plugin         GHC.Tc.Solver-        GHC.Tc.Solver.Canonical         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@@ -744,6 +774,12 @@         GHC.Tc.Types.EvTerm         GHC.Tc.Types.Origin         GHC.Tc.Types.Rank+        GHC.Tc.Types.CtLocEnv+        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,8 +788,11 @@         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@@ -771,6 +810,7 @@         GHC.Types.Fixity.Env         GHC.Types.ForeignCall         GHC.Types.ForeignStubs+        GHC.Types.GREInfo         GHC.Types.Hint         GHC.Types.Hint.Ppr         GHC.Types.HpcInfo@@ -792,6 +832,7 @@         GHC.Types.ProfAuto         GHC.Types.RepType         GHC.Types.SafeHaskell+        GHC.Types.SaneDouble         GHC.Types.SourceError         GHC.Types.SourceFile         GHC.Types.SourceText@@ -843,8 +884,6 @@         GHC.Utils.BufHandle         GHC.Utils.CliOption         GHC.Utils.Constants-        GHC.Utils.Containers.Internal.BitUtil-        GHC.Utils.Containers.Internal.StrictPair         GHC.Utils.Error         GHC.Utils.Exception         GHC.Utils.Fingerprint@@ -856,6 +895,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@@ -864,8 +904,6 @@         GHC.Utils.Ppr.Colour         GHC.Utils.TmpFs         GHC.Utils.Trace-        GHC.Utils.Unique-        GHC.Utils.Word64         GHC.Wasm.ControlFlow         GHC.Wasm.ControlFlow.FromCmm         GHC.CmmToAsm.Wasm
ghc-lib-parser.cabal view
@@ -1,8 +1,8 @@-cabal-version: 3.0+cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 9.6.7.20250325-license: BSD-3-Clause+version: 9.8.1.20231009+license: BSD3 license-file: LICENSE category: Development author: The GHC Team and Digital Asset@@ -51,7 +51,7 @@     compiler/GHC/Parser/Lexer.x     compiler/GHC/Parser/HaddockLex.x     compiler/GHC/Parser.hs-boot-    compiler/ghc-llvm-version.h+    libraries/containers/containers/include/containers.h     rts/include/ghcconfig.h     compiler/MachRegs.h     compiler/CodeGen.Platform.h@@ -59,6 +59,7 @@     compiler/ClosureTypes.h     compiler/FunTypes.h     compiler/Unique.h+    compiler/ghc-llvm-version.h source-repository head     type: git     location: git@github.com:digital-asset/ghc-lib.git@@ -67,15 +68,14 @@   manual: True   description: Pass -DTHREADED_RTS to the C toolchain library-    default-language: Haskell2010+    default-language:   Haskell2010     exposed: False     include-dirs:         rts/include         ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler-    if impl(ghc >= 8.8.1)-        ghc-options: -fno-safe-haskell+        libraries/containers/containers/include     if flag(threaded-rts)         ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS@@ -88,24 +88,22 @@     else         build-depends: Win32     build-depends:-        base >= 4.16.1 && < 4.19,-        ghc-prim > 0.2 && < 0.11,+        base >= 4.17.0.0 && < 4.20,+        ghc-prim > 0.2 && < 0.12,         containers >= 0.6.2.1 && < 0.7,-        bytestring >= 0.11.3 && < 0.12,+        bytestring >= 0.11.4 && < 0.12,         time >= 1.4 && < 1.13,-        filepath >= 1 && < 1.5,         exceptions == 0.10.*,         parsec,         binary == 0.8.*,+        filepath >= 1 && < 1.5,         directory >= 1 && < 1.4,         array >= 0.1 && < 0.6,         deepseq >= 1.4 && < 1.6,         pretty == 1.1.*,         transformers >= 0.5 && < 0.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.19.4     other-extensions:         BangPatterns         CPP@@ -146,13 +144,8 @@         NoImplicitPrelude         ScopedTypeVariables         TypeOperators-    if impl(ghc >= 9.2.2)-      cmm-sources:-            libraries/ghc-heap/cbits/HeapPrim.cmm-    else-      c-sources:-            libraries/ghc-heap/cbits/HeapPrim.cmm     c-sources:+        libraries/ghc-heap/cbits/HeapPrim.cmm         compiler/cbits/genSym.c         compiler/cbits/cutils.c         compiler/cbits/keepCAFsForGHCi.c@@ -210,12 +203,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@@ -272,13 +267,6 @@         GHC.Data.StringBuffer         GHC.Data.TrieMap         GHC.Data.Unboxed-        GHC.Data.Word64Map-        GHC.Data.Word64Map.Internal-        GHC.Data.Word64Map.Lazy-        GHC.Data.Word64Map.Strict-        GHC.Data.Word64Map.Strict.Internal-        GHC.Data.Word64Set-        GHC.Data.Word64Set.Internal         GHC.Driver.Backend         GHC.Driver.Backend.Internal         GHC.Driver.Backpack.Syntax@@ -288,6 +276,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@@ -341,10 +330,18 @@         GHC.HsToCore.Pmc.Ppr         GHC.HsToCore.Pmc.Solver.Types         GHC.HsToCore.Pmc.Types+        GHC.Iface.Decl+        GHC.Iface.Errors.Ppr+        GHC.Iface.Errors.Types         GHC.Iface.Ext.Fields         GHC.Iface.Recomp.Binary         GHC.Iface.Syntax         GHC.Iface.Type+        GHC.JS.Make+        GHC.JS.Ppr+        GHC.JS.Syntax+        GHC.JS.Transform+        GHC.JS.Unsat.Syntax         GHC.LanguageExtensions         GHC.LanguageExtensions.Type         GHC.Lexeme@@ -385,7 +382,6 @@         GHC.Runtime.Context         GHC.Runtime.Eval.Types         GHC.Runtime.Heap.Layout-        GHC.Runtime.Interpreter         GHC.Runtime.Interpreter.Types         GHC.Serialized         GHC.Settings@@ -393,22 +389,35 @@         GHC.Settings.Constants         GHC.Settings.Utils         GHC.Stg.InferTags.TagSig+        GHC.Stg.Lift.Types         GHC.Stg.Syntax         GHC.StgToCmm.Config         GHC.StgToCmm.Types+        GHC.StgToJS.Linker.Types+        GHC.StgToJS.Object+        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.CtLocEnv+        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@@ -425,6 +434,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,6 +455,7 @@         GHC.Types.ProfAuto         GHC.Types.RepType         GHC.Types.SafeHaskell+        GHC.Types.SaneDouble         GHC.Types.SourceError         GHC.Types.SourceFile         GHC.Types.SourceText@@ -452,6 +463,7 @@         GHC.Types.Target         GHC.Types.Tickish         GHC.Types.TyThing+        GHC.Types.TyThing.Ppr         GHC.Types.TypeEnv         GHC.Types.Unique         GHC.Types.Unique.DFM@@ -495,8 +507,6 @@         GHC.Utils.BufHandle         GHC.Utils.CliOption         GHC.Utils.Constants-        GHC.Utils.Containers.Internal.BitUtil-        GHC.Utils.Containers.Internal.StrictPair         GHC.Utils.Encoding         GHC.Utils.Encoding.UTF8         GHC.Utils.Error@@ -518,15 +528,11 @@         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         GHCi.RemoteTypes-        GHCi.ResolvedBCO         GHCi.TH.Binary         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic
ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs view
@@ -5,6 +5,7 @@   , cProjectName   , cBooterVersion   , cStage+  , cProjectUnitId   ) where  import GHC.Prelude.Basic@@ -21,7 +22,10 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "9.6.7"+cBooterVersion        = "9.4.5"  cStage                :: String cStage                = show (1 :: Int)++cProjectUnitId :: String+cProjectUnitId = "ghc-9.8.1-inplace"
ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -66,12 +66,12 @@ 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_Int16 = True primOpCanFail IndexByteArrayOp_Word16 = True+primOpCanFail IndexByteArrayOp_Int32 = True primOpCanFail IndexByteArrayOp_Word32 = True+primOpCanFail IndexByteArrayOp_Int64 = True primOpCanFail IndexByteArrayOp_Word64 = True primOpCanFail IndexByteArrayOp_Word8AsChar = True primOpCanFail IndexByteArrayOp_Word8AsWideChar = True@@ -82,10 +82,10 @@ 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_Word8AsInt32 = True primOpCanFail IndexByteArrayOp_Word8AsWord32 = True+primOpCanFail IndexByteArrayOp_Word8AsInt64 = True primOpCanFail IndexByteArrayOp_Word8AsWord64 = True primOpCanFail ReadByteArrayOp_Char = True primOpCanFail ReadByteArrayOp_WideChar = True@@ -96,12 +96,12 @@ 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_Int16 = True primOpCanFail ReadByteArrayOp_Word16 = True+primOpCanFail ReadByteArrayOp_Int32 = True primOpCanFail ReadByteArrayOp_Word32 = True+primOpCanFail ReadByteArrayOp_Int64 = True primOpCanFail ReadByteArrayOp_Word64 = True primOpCanFail ReadByteArrayOp_Word8AsChar = True primOpCanFail ReadByteArrayOp_Word8AsWideChar = True@@ -112,10 +112,10 @@ 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_Word8AsInt32 = True primOpCanFail ReadByteArrayOp_Word8AsWord32 = True+primOpCanFail ReadByteArrayOp_Word8AsInt64 = True primOpCanFail ReadByteArrayOp_Word8AsWord64 = True primOpCanFail WriteByteArrayOp_Char = True primOpCanFail WriteByteArrayOp_WideChar = True@@ -126,12 +126,12 @@ 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_Int16 = True primOpCanFail WriteByteArrayOp_Word16 = True+primOpCanFail WriteByteArrayOp_Int32 = True primOpCanFail WriteByteArrayOp_Word32 = True+primOpCanFail WriteByteArrayOp_Int64 = True primOpCanFail WriteByteArrayOp_Word64 = True primOpCanFail WriteByteArrayOp_Word8AsChar = True primOpCanFail WriteByteArrayOp_Word8AsWideChar = True@@ -142,18 +142,22 @@ 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_Word8AsInt32 = True primOpCanFail WriteByteArrayOp_Word8AsWord32 = True+primOpCanFail WriteByteArrayOp_Word8AsInt64 = True primOpCanFail WriteByteArrayOp_Word8AsWord64 = True primOpCanFail CompareByteArraysOp = True primOpCanFail CopyByteArrayOp = True primOpCanFail CopyMutableByteArrayOp = True+primOpCanFail CopyMutableByteArrayNonOverlappingOp = True primOpCanFail CopyByteArrayToAddrOp = True primOpCanFail CopyMutableByteArrayToAddrOp = True primOpCanFail CopyAddrToByteArrayOp = True+primOpCanFail CopyAddrToAddrOp = True+primOpCanFail CopyAddrToAddrNonOverlappingOp = True primOpCanFail SetByteArrayOp = True+primOpCanFail SetAddrRangeOp = True primOpCanFail AtomicReadByteArrayOp_Int = True primOpCanFail AtomicWriteByteArrayOp_Int = True primOpCanFail CasByteArrayOp_Int = True@@ -176,12 +180,12 @@ 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_Int16 = True primOpCanFail IndexOffAddrOp_Word16 = True+primOpCanFail IndexOffAddrOp_Int32 = True primOpCanFail IndexOffAddrOp_Word32 = True+primOpCanFail IndexOffAddrOp_Int64 = True primOpCanFail IndexOffAddrOp_Word64 = True primOpCanFail ReadOffAddrOp_Char = True primOpCanFail ReadOffAddrOp_WideChar = True@@ -192,12 +196,12 @@ 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_Int16 = True primOpCanFail ReadOffAddrOp_Word16 = True+primOpCanFail ReadOffAddrOp_Int32 = True primOpCanFail ReadOffAddrOp_Word32 = True+primOpCanFail ReadOffAddrOp_Int64 = True primOpCanFail ReadOffAddrOp_Word64 = True primOpCanFail WriteOffAddrOp_Char = True primOpCanFail WriteOffAddrOp_WideChar = True@@ -208,12 +212,12 @@ 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_Int16 = True primOpCanFail WriteOffAddrOp_Word16 = True+primOpCanFail WriteOffAddrOp_Int32 = True primOpCanFail WriteOffAddrOp_Word32 = True+primOpCanFail WriteOffAddrOp_Int64 = True primOpCanFail WriteOffAddrOp_Word64 = True primOpCanFail InterlockedExchange_Addr = True primOpCanFail InterlockedExchange_Word = True
ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -54,10 +54,14 @@ primOpCodeSize WriteArrayOp = 2 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
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -325,6 +325,14 @@    | FloatPowerOp    | FloatToDoubleOp    | FloatDecode_IntOp+   | FloatFMAdd+   | FloatFMSub+   | FloatFNMAdd+   | FloatFNMSub+   | DoubleFMAdd+   | DoubleFMSub+   | DoubleFNMAdd+   | DoubleFNMSub    | NewArrayOp    | ReadArrayOp    | WriteArrayOp@@ -379,12 +387,12 @@    | IndexByteArrayOp_Double    | IndexByteArrayOp_StablePtr    | IndexByteArrayOp_Int8-   | IndexByteArrayOp_Int16-   | IndexByteArrayOp_Int32-   | IndexByteArrayOp_Int64    | IndexByteArrayOp_Word8+   | IndexByteArrayOp_Int16    | IndexByteArrayOp_Word16+   | IndexByteArrayOp_Int32    | IndexByteArrayOp_Word32+   | IndexByteArrayOp_Int64    | IndexByteArrayOp_Word64    | IndexByteArrayOp_Word8AsChar    | IndexByteArrayOp_Word8AsWideChar@@ -395,10 +403,10 @@    | IndexByteArrayOp_Word8AsDouble    | IndexByteArrayOp_Word8AsStablePtr    | IndexByteArrayOp_Word8AsInt16-   | IndexByteArrayOp_Word8AsInt32-   | IndexByteArrayOp_Word8AsInt64    | IndexByteArrayOp_Word8AsWord16+   | IndexByteArrayOp_Word8AsInt32    | IndexByteArrayOp_Word8AsWord32+   | IndexByteArrayOp_Word8AsInt64    | IndexByteArrayOp_Word8AsWord64    | ReadByteArrayOp_Char    | ReadByteArrayOp_WideChar@@ -409,12 +417,12 @@    | ReadByteArrayOp_Double    | ReadByteArrayOp_StablePtr    | ReadByteArrayOp_Int8-   | ReadByteArrayOp_Int16-   | ReadByteArrayOp_Int32-   | ReadByteArrayOp_Int64    | ReadByteArrayOp_Word8+   | ReadByteArrayOp_Int16    | ReadByteArrayOp_Word16+   | ReadByteArrayOp_Int32    | ReadByteArrayOp_Word32+   | ReadByteArrayOp_Int64    | ReadByteArrayOp_Word64    | ReadByteArrayOp_Word8AsChar    | ReadByteArrayOp_Word8AsWideChar@@ -425,10 +433,10 @@    | ReadByteArrayOp_Word8AsDouble    | ReadByteArrayOp_Word8AsStablePtr    | ReadByteArrayOp_Word8AsInt16-   | ReadByteArrayOp_Word8AsInt32-   | ReadByteArrayOp_Word8AsInt64    | ReadByteArrayOp_Word8AsWord16+   | ReadByteArrayOp_Word8AsInt32    | ReadByteArrayOp_Word8AsWord32+   | ReadByteArrayOp_Word8AsInt64    | ReadByteArrayOp_Word8AsWord64    | WriteByteArrayOp_Char    | WriteByteArrayOp_WideChar@@ -439,12 +447,12 @@    | WriteByteArrayOp_Double    | WriteByteArrayOp_StablePtr    | WriteByteArrayOp_Int8-   | WriteByteArrayOp_Int16-   | WriteByteArrayOp_Int32-   | WriteByteArrayOp_Int64    | WriteByteArrayOp_Word8+   | WriteByteArrayOp_Int16    | WriteByteArrayOp_Word16+   | WriteByteArrayOp_Int32    | WriteByteArrayOp_Word32+   | WriteByteArrayOp_Int64    | WriteByteArrayOp_Word64    | WriteByteArrayOp_Word8AsChar    | WriteByteArrayOp_Word8AsWideChar@@ -455,18 +463,22 @@    | WriteByteArrayOp_Word8AsDouble    | WriteByteArrayOp_Word8AsStablePtr    | WriteByteArrayOp_Word8AsInt16-   | WriteByteArrayOp_Word8AsInt32-   | WriteByteArrayOp_Word8AsInt64    | WriteByteArrayOp_Word8AsWord16+   | WriteByteArrayOp_Word8AsInt32    | WriteByteArrayOp_Word8AsWord32+   | WriteByteArrayOp_Word8AsInt64    | WriteByteArrayOp_Word8AsWord64    | CompareByteArraysOp    | CopyByteArrayOp    | CopyMutableByteArrayOp+   | CopyMutableByteArrayNonOverlappingOp    | CopyByteArrayToAddrOp    | CopyMutableByteArrayToAddrOp    | CopyAddrToByteArrayOp+   | CopyAddrToAddrOp+   | CopyAddrToAddrNonOverlappingOp    | SetByteArrayOp+   | SetAddrRangeOp    | AtomicReadByteArrayOp_Int    | AtomicWriteByteArrayOp_Int    | CasByteArrayOp_Int@@ -500,12 +512,12 @@    | IndexOffAddrOp_Double    | IndexOffAddrOp_StablePtr    | IndexOffAddrOp_Int8-   | IndexOffAddrOp_Int16-   | IndexOffAddrOp_Int32-   | IndexOffAddrOp_Int64    | IndexOffAddrOp_Word8+   | IndexOffAddrOp_Int16    | IndexOffAddrOp_Word16+   | IndexOffAddrOp_Int32    | IndexOffAddrOp_Word32+   | IndexOffAddrOp_Int64    | IndexOffAddrOp_Word64    | ReadOffAddrOp_Char    | ReadOffAddrOp_WideChar@@ -516,12 +528,12 @@    | ReadOffAddrOp_Double    | ReadOffAddrOp_StablePtr    | ReadOffAddrOp_Int8-   | ReadOffAddrOp_Int16-   | ReadOffAddrOp_Int32-   | ReadOffAddrOp_Int64    | ReadOffAddrOp_Word8+   | ReadOffAddrOp_Int16    | ReadOffAddrOp_Word16+   | ReadOffAddrOp_Int32    | ReadOffAddrOp_Word32+   | ReadOffAddrOp_Int64    | ReadOffAddrOp_Word64    | WriteOffAddrOp_Char    | WriteOffAddrOp_WideChar@@ -532,12 +544,12 @@    | WriteOffAddrOp_Double    | WriteOffAddrOp_StablePtr    | WriteOffAddrOp_Int8-   | WriteOffAddrOp_Int16-   | WriteOffAddrOp_Int32-   | WriteOffAddrOp_Int64    | WriteOffAddrOp_Word8+   | WriteOffAddrOp_Int16    | WriteOffAddrOp_Word16+   | WriteOffAddrOp_Int32    | WriteOffAddrOp_Word32+   | WriteOffAddrOp_Int64    | WriteOffAddrOp_Word64    | InterlockedExchange_Addr    | InterlockedExchange_Word@@ -558,6 +570,7 @@    | NewMutVarOp    | ReadMutVarOp    | WriteMutVarOp+   | AtomicSwapMutVarOp    | AtomicModifyMutVar2Op    | AtomicModifyMutVar_Op    | CasMutVarOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -30,16 +30,16 @@   , ("popCnt32#","Count the number of set bits in the lower 32 bits of a word.")   , ("popCnt64#","Count the number of set bits in a 64-bit word.")   , ("popCnt#","Count the number of set bits in a word.")-  , ("pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.")-  , ("pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.")-  , ("pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.")-  , ("pdep64#","Deposit bits to a word at locations specified by a mask.")-  , ("pdep#","Deposit bits to a word at locations specified by a mask.")-  , ("pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.")-  , ("pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.")-  , ("pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.")-  , ("pext64#","Extract bits from a word at locations specified by a mask.")-  , ("pext#","Extract bits from a word at locations specified by a mask.")+  , ("pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pdep64#","Deposit bits to a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pdep#","Deposit bits to a word at locations specified by a mask, aka\n    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n    Software emulation:\n\n    > pdep :: Word -> Word -> Word\n    > pdep src mask = go 0 src mask\n    >   where\n    >     go :: Word -> Word -> Word -> Word\n    >     go result _ 0 = result\n    >     go result src mask = go newResult newSrc newMask\n    >       where\n    >         maskCtz   = countTrailingZeros mask\n    >         newResult = if testBit src 0 then setBit result maskCtz else result\n    >         newSrc    = src `shiftR` 1\n    >         newMask   = clearBit mask maskCtz\n\n    @since 0.5.2.0")+  , ("pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pext64#","Extract bits from a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , ("pext#","Extract bits from a word at locations specified by a mask, aka\n    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n    Software emulation:\n\n    > pext :: Word -> Word -> Word\n    > pext src mask = loop 0 0 0\n    >   where\n    >     loop i count result\n    >       | i >= finiteBitSize (0 :: Word)\n    >       = result\n    >       | testBit mask i\n    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)\n    >       | otherwise\n    >       = loop (i + 1) count result\n\n    @since 0.5.2.0")   , ("clz8#","Count leading zeros in the lower 8 bits of a word.")   , ("clz16#","Count leading zeros in the lower 16 bits of a word.")   , ("clz32#","Count leading zeros in the lower 32 bits of a word.")@@ -65,6 +65,14 @@   , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")   , ("float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , ("decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")+  , ("fmaddFloat#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , ("fmsubFloat#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , ("fnmaddFloat#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , ("fnmsubFloat#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")+  , ("fmaddDouble#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , ("fmsubDouble#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , ("fnmaddDouble#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , ("fnmsubDouble#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")   , ("newArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")   , ("readArray#","Read from specified index of mutable array. Result is not yet evaluated.")   , ("writeArray#","Write to specified index of mutable array.")@@ -81,12 +89,12 @@   , ("thawArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than 'casIntArray#'. All of the difficulties\n    of using 'reallyUnsafePtrEquality#' correctly apply to\n    'casArray#' as well.\n   ")   , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")-  , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofSmallMutableArray#'.")+  , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofSmallMutableArray#'.\n\n    Assuming the non-profiling RTS, for the copying garbage collector\n    (default) this primitive compiles to an O(1) operation in C--, modifying\n    the array in-place. For the non-moving garbage collector, however, the\n    time is proportional to the number of elements shrinked out. Backends\n    bypassing C-- representation (such as JavaScript) might behave\n    differently.\n\n    @since 0.6.1")   , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.")   , ("writeSmallArray#","Write to specified index of mutable array.")   , ("sizeofSmallArray#","Return the number of elements in the array.")-  , ("sizeofSmallMutableArray#","Return the number of elements in the array. Note that this is deprecated\n   as it is unsafe in the presence of shrink and resize operations on the\n   same small mutable array.")-  , ("getSizeofSmallMutableArray#","Return the number of elements in the array.")+  , ("sizeofSmallMutableArray#","Return the number of elements in the array. __Deprecated__, it is\n   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@\n   operations on the same small mutable array.")+  , ("getSizeofSmallMutableArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.\n\n   @since 0.6.1")   , ("indexSmallArray#","Read from specified index of immutable array. Result is packaged into\n    an unboxed singleton; the result itself is not yet evaluated.")   , ("unsafeFreezeSmallArray#","Make a mutable array immutable, without copying.")   , ("unsafeThawSmallArray#","Make an immutable array mutable, without copying.")@@ -106,13 +114,13 @@   , ("isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move during GC.")   , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")   , ("mutableByteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")-  , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.")-  , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.")+  , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.\n\n    Assuming the non-profiling RTS, this primitive compiles to an O(1)\n    operation in C--, modifying the array in-place. Backends bypassing C--\n    representation (such as JavaScript) might behave differently.\n\n    @since 0.4.0.0")+  , ("resizeMutableByteArray#","Resize mutable byte array to new specified size (in bytes), shrinking or growing it.\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.\n\n    @since 0.4.0.0")   , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.")   , ("sizeofByteArray#","Return the size of the array in bytes.")-  , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n   unsafe in the presence of shrink and resize operations on the same mutable byte\n   array.")-  , ("getSizeofMutableByteArray#","Return the number of elements in the array.")-  , ("indexCharArray#","Read a 8-bit character; offset in bytes.")+  , ("sizeofMutableByteArray#","Return the size of the array in bytes. __Deprecated__, it is\n   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'\n   operations on the same mutable byte\n   array.")+  , ("getSizeofMutableByteArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.\n\n   @since 0.5.0.0")+  , ("indexCharArray#","Read an 8-bit character; offset in bytes.")   , ("indexWideCharArray#","Read a 32-bit character; offset in 4-byte words.")   , ("indexIntArray#","Read a word-sized integer; offset in machine words.")   , ("indexWordArray#","Read a word-sized unsigned integer; offset in machine words.")@@ -120,15 +128,15 @@   , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")   , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")   , ("indexStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")-  , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.")+  , ("indexInt8Array#","Read an 8-bit signed integer; offset in bytes.")+  , ("indexWord8Array#","Read an 8-bit unsigned integer; offset in bytes.")   , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")-  , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")-  , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")-  , ("indexWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")   , ("indexWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")+  , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")   , ("indexWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")+  , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")   , ("indexWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")-  , ("indexWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")+  , ("indexWord8ArrayAsChar#","Read an 8-bit character; offset in bytes.")   , ("indexWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")   , ("indexWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")   , ("indexWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")@@ -137,12 +145,12 @@   , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")   , ("indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")   , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")-  , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")-  , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")   , ("indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+  , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")   , ("indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+  , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")   , ("indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")-  , ("readCharArray#","Read a 8-bit character; offset in bytes.")+  , ("readCharArray#","Read an 8-bit character; offset in bytes.")   , ("readWideCharArray#","Read a 32-bit character; offset in 4-byte words.")   , ("readIntArray#","Read a word-sized integer; offset in machine words.")   , ("readWordArray#","Read a word-sized unsigned integer; offset in machine words.")@@ -150,15 +158,15 @@   , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")   , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")   , ("readStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")-  , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.")+  , ("readInt8Array#","Read an 8-bit signed integer; offset in bytes.")+  , ("readWord8Array#","Read an 8-bit unsigned integer; offset in bytes.")   , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")-  , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")-  , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")-  , ("readWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")   , ("readWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")+  , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")   , ("readWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")+  , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")   , ("readWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")-  , ("readWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")+  , ("readWord8ArrayAsChar#","Read an 8-bit character; offset in bytes.")   , ("readWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")   , ("readWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")   , ("readWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")@@ -167,12 +175,12 @@   , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")   , ("readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")   , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")-  , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")-  , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")   , ("readWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+  , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")   , ("readWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+  , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")   , ("readWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")-  , ("writeCharArray#","Write a 8-bit character; offset in bytes.")+  , ("writeCharArray#","Write an 8-bit character; offset in bytes.")   , ("writeWideCharArray#","Write a 32-bit character; offset in 4-byte words.")   , ("writeIntArray#","Write a word-sized integer; offset in machine words.")   , ("writeWordArray#","Write a word-sized unsigned integer; offset in machine words.")@@ -180,15 +188,15 @@   , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.")   , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.")   , ("writeStablePtrArray#","Write a 'StablePtr#' value; offset in machine words.")-  , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.")+  , ("writeInt8Array#","Write an 8-bit signed integer; offset in bytes.")+  , ("writeWord8Array#","Write an 8-bit unsigned integer; offset in bytes.")   , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.")-  , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")-  , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.")-  , ("writeWord8Array#","Write a 8-bit unsigned integer; offset in bytes.")   , ("writeWord16Array#","Write a 16-bit unsigned integer; offset in 2-byte words.")+  , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")   , ("writeWord32Array#","Write a 32-bit unsigned integer; offset in 4-byte words.")+  , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.")   , ("writeWord64Array#","Write a 64-bit unsigned integer; offset in 8-byte words.")-  , ("writeWord8ArrayAsChar#","Write a 8-bit character; offset in bytes.")+  , ("writeWord8ArrayAsChar#","Write an 8-bit character; offset in bytes.")   , ("writeWord8ArrayAsWideChar#","Write a 32-bit character; offset in bytes.")   , ("writeWord8ArrayAsInt#","Write a word-sized integer; offset in bytes.")   , ("writeWord8ArrayAsWord#","Write a word-sized unsigned integer; offset in bytes.")@@ -197,18 +205,22 @@   , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.")   , ("writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.")   , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.")-  , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")-  , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")+  , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")+  , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")   , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.")-  , ("copyByteArray#","@'copyByteArray#' src src_ofs dst dst_ofs n@ copies the range\n   starting at offset @src_ofs@ of length @n@ from the\n   'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n   starting at offset @dst_ofs@.  Both arrays must fully contain\n   the specified ranges, but this is not checked.  The two arrays must\n   not be the same array in different states, but this is not checked\n   either.")-  , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n   Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n   allowed to overlap, although this is only possible when the same array is provided\n   as both the source and the destination.")+  , ("copyByteArray#"," @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range\n    starting at offset @src_ofs@ of length @len@ from the\n    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain\n    the specified ranges, but this is not checked.  The two arrays must\n    not be the same array in different states, but this is not checked\n    either.\n  ")+  , ("copyMutableByteArray#"," @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the\n    range starting at offset @src_ofs@ of length @len@ from the\n    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are\n    allowed to overlap, although this is only possible when the same\n    array is provided as both the source and the destination.\n  ")+  , ("copyMutableByteArrayNonOverlapping#"," @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@\n    copies the range starting at offset @src_ofs@ of length @len@ from\n    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are /not/\n    allowed to overlap, but this is also not checked.\n\n    @since 0.11.0\n  ")   , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n   The ByteArray\\# and the memory region at Addr\\# must fully contain the\n   specified ranges, but this is not checked. The Addr\\# must not point into the\n   ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n   either.")   , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n   Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n   pinned), but this is not checked either.")   , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n   MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n   but this is not checked either.")+  , ("copyAddrToAddr#"," @'copyAddrToAddr#' src dest len@ copies @len@ bytes\n    from @src@ to @dest@.  These two memory ranges are allowed to overlap.\n\n    Analogous to the standard C function @memmove@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")+  , ("copyAddrToAddrNonOverlapping#"," @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes\n    from @src@ to @dest@.  As the name suggests, these two memory ranges\n    /must not overlap/, although this pre-condition is not checked.\n\n    Analogous to the standard C function @memcpy@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")   , ("setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n   the 'MutableByteArray#' to the byte @c@.")+  , ("setAddrRange#"," @'setAddrRange#' dest len c@ sets all of the bytes in\n    @[dest, dest+len)@ to the value @c@.\n\n    Analogous to the standard C function @memset@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")   , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")@@ -228,10 +240,54 @@   , ("remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n          is divided by the 'Int#' arg.")   , ("addr2Int#","Coerce directly from address to int.")   , ("int2Addr#","Coerce directly from int to address.")-  , ("indexCharOffAddr#","Reads 8-bit character; offset in bytes.")-  , ("indexWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.")-  , ("readCharOffAddr#","Reads 8-bit character; offset in bytes.")-  , ("readWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.")+  , ("indexCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n")+  , ("indexWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexWordOffAddr#","Read a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexAddrOffAddr#","Read a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexFloatOffAddr#","Read a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexDoubleOffAddr#","Read a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexStablePtrOffAddr#","Read a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexInt8OffAddr#","Read an 8-bit signed integer; offset in bytes.\n\n")+  , ("indexWord8OffAddr#","Read an 8-bit unsigned integer; offset in bytes.\n\n")+  , ("indexInt16OffAddr#","Read a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexWord16OffAddr#","Read a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexInt32OffAddr#","Read a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n")+  , ("readWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readWordOffAddr#","Read a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readAddrOffAddr#","Read a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readFloatOffAddr#","Read a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readDoubleOffAddr#","Read a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readStablePtrOffAddr#","Read a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readInt8OffAddr#","Read an 8-bit signed integer; offset in bytes.\n\n")+  , ("readWord8OffAddr#","Read an 8-bit unsigned integer; offset in bytes.\n\n")+  , ("readInt16OffAddr#","Read a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readWord16OffAddr#","Read a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readInt32OffAddr#","Read a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeCharOffAddr#","Write an 8-bit character; offset in bytes.\n\n")+  , ("writeWideCharOffAddr#","Write a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeIntOffAddr#","Write a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeWordOffAddr#","Write a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeAddrOffAddr#","Write a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeFloatOffAddr#","Write a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeDoubleOffAddr#","Write a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeStablePtrOffAddr#","Write a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeInt8OffAddr#","Write an 8-bit signed integer; offset in bytes.\n\n")+  , ("writeWord8OffAddr#","Write an 8-bit unsigned integer; offset in bytes.\n\n")+  , ("writeInt16OffAddr#","Write a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeWord16OffAddr#","Write a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeInt32OffAddr#","Write a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeWord32OffAddr#","Write a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeInt64OffAddr#","Write a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeWord64OffAddr#","Write a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("atomicExchangeAddrAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n    with the Addr# given as second argument. Implies a read barrier.")   , ("atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n    with the given value. Returns the old value. Implies a read barrier.")   , ("atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n     Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")@@ -252,7 +308,8 @@   , ("newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.")   , ("readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.")   , ("writeMutVar#","Write contents of 'MutVar#'.")-  , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n     contents and the result of applying the given function to the\n     previous contents. Note that this isn't strictly\n     speaking the correct type for this function; it should really be\n     @'MutVar#' s a -> (a -> (a,b)) -> 'State#' s -> (# 'State#' s, a, (a, b) #)@,\n     but we don't know about pairs here. ")+  , ("atomicSwapMutVar#","Atomically exchange the value of a 'MutVar#'.")+  , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n     contents @x :: a@ and the result of applying the given function to the\n     previous contents @f x :: c@.\n\n     The @data@ type @c@ (not a @newtype@!) must be a record whose first field\n     is of lifted type @a :: Type@ and is not unpacked. For example, product\n     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both\n     monomorphic and strict in its first field, it's recommended to mark the\n     latter @{-# NOUNPACK #-}@ explicitly.\n\n     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an\n     old @x :: a@ with a pointer to a selector thunk @fst r@, where\n     @fst@ is a selector for the first field of the record and @r@ is a\n     function application thunk @r = f x@.\n\n     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an\n     effort to reflect restrictions on @c@ faithfully, providing a\n     well-typed high-level wrapper.")   , ("atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n     contents and the result of applying the given function to the\n     previous contents. ")   , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n     the first value passed to this function and the value\n     stored inside the 'MutVar#'. If the pointers are equal,\n     replace the stored value with the second value passed to this\n     function, otherwise do nothing.\n     Returns the final value stored inside the 'MutVar#'.\n     The 'Int#' indicates whether a swap took place,\n     with @1#@ meaning that we didn't swap, and @0#@\n     that we did.\n     Implies a full memory barrier.\n     Because the comparison is done on the level of pointers,\n     all of the difficulties of using\n     'reallyUnsafePtrEquality#' correctly apply to\n     'casMutVar#' as well.\n   ")   , ("catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n     thrown.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")@@ -324,13 +381,12 @@   , ("Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A 'Proxy#'\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")   , ("proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n   representation. ")   , ("seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). 'seq' is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @'seq' a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by 'seq' is that the both @a@\n     and @b@ will be evaluated before 'seq' returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function 'pseq' from the \"parallel\" package. ")-  , ("unsafeCoerce#"," The function 'unsafeCoerce#' allows you to side-step the typechecker entirely. That\n        is, it allows you to coerce any type into any other type. If you use this function,\n        you had better get it right, otherwise segmentation faults await. It is generally\n        used when you want to write a program that you know is well-typed, but where Haskell's\n        type system is not expressive enough to prove that it is well typed.\n\n        The following uses of 'unsafeCoerce#' are supposed to work (i.e. not lead to\n        spurious compile-time or run-time crashes):\n\n         * Casting any lifted type to 'Any'\n\n         * Casting 'Any' back to the real type\n\n         * Casting an unboxed type to another unboxed type of the same size.\n           (Casting between floating-point and integral types does not work.\n           See the \"GHC.Float\" module for functions to do work.)\n\n         * Casting between two types that have the same runtime representation.  One case is when\n           the two types differ only in \"phantom\" type parameters, for example\n           @'Ptr' 'Int'@ to @'Ptr' 'Float'@, or @['Int']@ to @['Float']@ when the list is\n           known to be empty.  Also, a @newtype@ of a type @T@ has the same representation\n           at runtime as @T@.\n\n        Other uses of 'unsafeCoerce#' are undefined.  In particular, you should not use\n        'unsafeCoerce#' to cast a T to an algebraic data type D, unless T is also\n        an algebraic data type.  For example, do not cast @'Int'->'Int'@ to 'Bool', even if\n        you later cast that 'Bool' back to @'Int'->'Int'@ before applying it.  The reasons\n        have to do with GHC's internal representation details (for the cognoscenti, data values\n        can be entered but function closures cannot).  If you want a safe type to cast things\n        to, use 'Any', which is not an algebraic data type.\n\n        ")   , ("traceEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the binary object passed as the first argument with\n     the given length passed as the second argument. The event will be\n     emitted to the @.eventlog@ file. ")   , ("traceMarker#"," Emits a marker event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")   , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in \"GHC.Stack.CloneStack\". Please check the\n     documentation in that module for more detailed explanations. ")-  , ("coerce"," The function 'coerce' allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     When used in conversions involving a newtype wrapper,\n     make sure the newtype constructor is in scope.\n\n     This function is representation-polymorphic, but the\n     'RuntimeRep' type argument is marked as 'Inferred', meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n\n     === __Examples__\n\n     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)\n     >>> newtype Age = Age Int deriving (Eq, Ord, Show)\n     >>> coerce (Age 42) :: TTL\n     TTL 42\n     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL\n     TTL 43\n     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]\n     [TTL 43,TTL 25]\n\n   ")+  , ("coerce"," The function 'coerce' allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     This function is representation-polymorphic, but the\n     'RuntimeRep' type argument is marked as 'Inferred', meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n   ")   , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -38,12 +38,12 @@ primOpHasSideEffects ReadByteArrayOp_Double = True primOpHasSideEffects ReadByteArrayOp_StablePtr = True primOpHasSideEffects ReadByteArrayOp_Int8 = True-primOpHasSideEffects ReadByteArrayOp_Int16 = True-primOpHasSideEffects ReadByteArrayOp_Int32 = True-primOpHasSideEffects ReadByteArrayOp_Int64 = True primOpHasSideEffects ReadByteArrayOp_Word8 = True+primOpHasSideEffects ReadByteArrayOp_Int16 = True primOpHasSideEffects ReadByteArrayOp_Word16 = True+primOpHasSideEffects ReadByteArrayOp_Int32 = True primOpHasSideEffects ReadByteArrayOp_Word32 = True+primOpHasSideEffects ReadByteArrayOp_Int64 = True primOpHasSideEffects ReadByteArrayOp_Word64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True@@ -54,10 +54,10 @@ primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True primOpHasSideEffects WriteByteArrayOp_Char = True primOpHasSideEffects WriteByteArrayOp_WideChar = True@@ -68,12 +68,12 @@ primOpHasSideEffects WriteByteArrayOp_Double = True primOpHasSideEffects WriteByteArrayOp_StablePtr = True primOpHasSideEffects WriteByteArrayOp_Int8 = True-primOpHasSideEffects WriteByteArrayOp_Int16 = True-primOpHasSideEffects WriteByteArrayOp_Int32 = True-primOpHasSideEffects WriteByteArrayOp_Int64 = True primOpHasSideEffects WriteByteArrayOp_Word8 = True+primOpHasSideEffects WriteByteArrayOp_Int16 = True primOpHasSideEffects WriteByteArrayOp_Word16 = True+primOpHasSideEffects WriteByteArrayOp_Int32 = True primOpHasSideEffects WriteByteArrayOp_Word32 = True+primOpHasSideEffects WriteByteArrayOp_Int64 = True primOpHasSideEffects WriteByteArrayOp_Word64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True@@ -84,17 +84,21 @@ primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True primOpHasSideEffects CopyByteArrayOp = True primOpHasSideEffects CopyMutableByteArrayOp = True+primOpHasSideEffects CopyMutableByteArrayNonOverlappingOp = True primOpHasSideEffects CopyByteArrayToAddrOp = True primOpHasSideEffects CopyMutableByteArrayToAddrOp = True primOpHasSideEffects CopyAddrToByteArrayOp = True+primOpHasSideEffects CopyAddrToAddrOp = True+primOpHasSideEffects CopyAddrToAddrNonOverlappingOp = True primOpHasSideEffects SetByteArrayOp = True+primOpHasSideEffects SetAddrRangeOp = True primOpHasSideEffects AtomicReadByteArrayOp_Int = True primOpHasSideEffects AtomicWriteByteArrayOp_Int = True primOpHasSideEffects CasByteArrayOp_Int = True@@ -117,12 +121,12 @@ primOpHasSideEffects ReadOffAddrOp_Double = True primOpHasSideEffects ReadOffAddrOp_StablePtr = True primOpHasSideEffects ReadOffAddrOp_Int8 = True-primOpHasSideEffects ReadOffAddrOp_Int16 = True-primOpHasSideEffects ReadOffAddrOp_Int32 = True-primOpHasSideEffects ReadOffAddrOp_Int64 = True primOpHasSideEffects ReadOffAddrOp_Word8 = True+primOpHasSideEffects ReadOffAddrOp_Int16 = True primOpHasSideEffects ReadOffAddrOp_Word16 = True+primOpHasSideEffects ReadOffAddrOp_Int32 = True primOpHasSideEffects ReadOffAddrOp_Word32 = True+primOpHasSideEffects ReadOffAddrOp_Int64 = True primOpHasSideEffects ReadOffAddrOp_Word64 = True primOpHasSideEffects WriteOffAddrOp_Char = True primOpHasSideEffects WriteOffAddrOp_WideChar = True@@ -133,12 +137,12 @@ primOpHasSideEffects WriteOffAddrOp_Double = True primOpHasSideEffects WriteOffAddrOp_StablePtr = True primOpHasSideEffects WriteOffAddrOp_Int8 = True-primOpHasSideEffects WriteOffAddrOp_Int16 = True-primOpHasSideEffects WriteOffAddrOp_Int32 = True-primOpHasSideEffects WriteOffAddrOp_Int64 = True primOpHasSideEffects WriteOffAddrOp_Word8 = True+primOpHasSideEffects WriteOffAddrOp_Int16 = True primOpHasSideEffects WriteOffAddrOp_Word16 = True+primOpHasSideEffects WriteOffAddrOp_Int32 = True primOpHasSideEffects WriteOffAddrOp_Word32 = True+primOpHasSideEffects WriteOffAddrOp_Int64 = True primOpHasSideEffects WriteOffAddrOp_Word64 = True primOpHasSideEffects InterlockedExchange_Addr = True primOpHasSideEffects InterlockedExchange_Word = True@@ -159,6 +163,7 @@ primOpHasSideEffects NewMutVarOp = True primOpHasSideEffects ReadMutVarOp = True primOpHasSideEffects WriteMutVarOp = True+primOpHasSideEffects AtomicSwapMutVarOp = True primOpHasSideEffects AtomicModifyMutVar2Op = True primOpHasSideEffects AtomicModifyMutVar_Op = True primOpHasSideEffects CasMutVarOp = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -324,6 +324,14 @@    , FloatPowerOp    , FloatToDoubleOp    , FloatDecode_IntOp+   , FloatFMAdd+   , FloatFMSub+   , FloatFNMAdd+   , FloatFNMSub+   , DoubleFMAdd+   , DoubleFMSub+   , DoubleFNMAdd+   , DoubleFNMSub    , NewArrayOp    , ReadArrayOp    , WriteArrayOp@@ -378,12 +386,12 @@    , IndexByteArrayOp_Double    , IndexByteArrayOp_StablePtr    , IndexByteArrayOp_Int8-   , IndexByteArrayOp_Int16-   , IndexByteArrayOp_Int32-   , IndexByteArrayOp_Int64    , IndexByteArrayOp_Word8+   , IndexByteArrayOp_Int16    , IndexByteArrayOp_Word16+   , IndexByteArrayOp_Int32    , IndexByteArrayOp_Word32+   , IndexByteArrayOp_Int64    , IndexByteArrayOp_Word64    , IndexByteArrayOp_Word8AsChar    , IndexByteArrayOp_Word8AsWideChar@@ -394,10 +402,10 @@    , IndexByteArrayOp_Word8AsDouble    , IndexByteArrayOp_Word8AsStablePtr    , IndexByteArrayOp_Word8AsInt16-   , IndexByteArrayOp_Word8AsInt32-   , IndexByteArrayOp_Word8AsInt64    , IndexByteArrayOp_Word8AsWord16+   , IndexByteArrayOp_Word8AsInt32    , IndexByteArrayOp_Word8AsWord32+   , IndexByteArrayOp_Word8AsInt64    , IndexByteArrayOp_Word8AsWord64    , ReadByteArrayOp_Char    , ReadByteArrayOp_WideChar@@ -408,12 +416,12 @@    , ReadByteArrayOp_Double    , ReadByteArrayOp_StablePtr    , ReadByteArrayOp_Int8-   , ReadByteArrayOp_Int16-   , ReadByteArrayOp_Int32-   , ReadByteArrayOp_Int64    , ReadByteArrayOp_Word8+   , ReadByteArrayOp_Int16    , ReadByteArrayOp_Word16+   , ReadByteArrayOp_Int32    , ReadByteArrayOp_Word32+   , ReadByteArrayOp_Int64    , ReadByteArrayOp_Word64    , ReadByteArrayOp_Word8AsChar    , ReadByteArrayOp_Word8AsWideChar@@ -424,10 +432,10 @@    , ReadByteArrayOp_Word8AsDouble    , ReadByteArrayOp_Word8AsStablePtr    , ReadByteArrayOp_Word8AsInt16-   , ReadByteArrayOp_Word8AsInt32-   , ReadByteArrayOp_Word8AsInt64    , ReadByteArrayOp_Word8AsWord16+   , ReadByteArrayOp_Word8AsInt32    , ReadByteArrayOp_Word8AsWord32+   , ReadByteArrayOp_Word8AsInt64    , ReadByteArrayOp_Word8AsWord64    , WriteByteArrayOp_Char    , WriteByteArrayOp_WideChar@@ -438,12 +446,12 @@    , WriteByteArrayOp_Double    , WriteByteArrayOp_StablePtr    , WriteByteArrayOp_Int8-   , WriteByteArrayOp_Int16-   , WriteByteArrayOp_Int32-   , WriteByteArrayOp_Int64    , WriteByteArrayOp_Word8+   , WriteByteArrayOp_Int16    , WriteByteArrayOp_Word16+   , WriteByteArrayOp_Int32    , WriteByteArrayOp_Word32+   , WriteByteArrayOp_Int64    , WriteByteArrayOp_Word64    , WriteByteArrayOp_Word8AsChar    , WriteByteArrayOp_Word8AsWideChar@@ -454,18 +462,22 @@    , WriteByteArrayOp_Word8AsDouble    , WriteByteArrayOp_Word8AsStablePtr    , WriteByteArrayOp_Word8AsInt16-   , WriteByteArrayOp_Word8AsInt32-   , WriteByteArrayOp_Word8AsInt64    , WriteByteArrayOp_Word8AsWord16+   , WriteByteArrayOp_Word8AsInt32    , WriteByteArrayOp_Word8AsWord32+   , WriteByteArrayOp_Word8AsInt64    , WriteByteArrayOp_Word8AsWord64    , CompareByteArraysOp    , CopyByteArrayOp    , CopyMutableByteArrayOp+   , CopyMutableByteArrayNonOverlappingOp    , CopyByteArrayToAddrOp    , CopyMutableByteArrayToAddrOp    , CopyAddrToByteArrayOp+   , CopyAddrToAddrOp+   , CopyAddrToAddrNonOverlappingOp    , SetByteArrayOp+   , SetAddrRangeOp    , AtomicReadByteArrayOp_Int    , AtomicWriteByteArrayOp_Int    , CasByteArrayOp_Int@@ -499,12 +511,12 @@    , IndexOffAddrOp_Double    , IndexOffAddrOp_StablePtr    , IndexOffAddrOp_Int8-   , IndexOffAddrOp_Int16-   , IndexOffAddrOp_Int32-   , IndexOffAddrOp_Int64    , IndexOffAddrOp_Word8+   , IndexOffAddrOp_Int16    , IndexOffAddrOp_Word16+   , IndexOffAddrOp_Int32    , IndexOffAddrOp_Word32+   , IndexOffAddrOp_Int64    , IndexOffAddrOp_Word64    , ReadOffAddrOp_Char    , ReadOffAddrOp_WideChar@@ -515,12 +527,12 @@    , ReadOffAddrOp_Double    , ReadOffAddrOp_StablePtr    , ReadOffAddrOp_Int8-   , ReadOffAddrOp_Int16-   , ReadOffAddrOp_Int32-   , ReadOffAddrOp_Int64    , ReadOffAddrOp_Word8+   , ReadOffAddrOp_Int16    , ReadOffAddrOp_Word16+   , ReadOffAddrOp_Int32    , ReadOffAddrOp_Word32+   , ReadOffAddrOp_Int64    , ReadOffAddrOp_Word64    , WriteOffAddrOp_Char    , WriteOffAddrOp_WideChar@@ -531,12 +543,12 @@    , WriteOffAddrOp_Double    , WriteOffAddrOp_StablePtr    , WriteOffAddrOp_Int8-   , WriteOffAddrOp_Int16-   , WriteOffAddrOp_Int32-   , WriteOffAddrOp_Int64    , WriteOffAddrOp_Word8+   , WriteOffAddrOp_Int16    , WriteOffAddrOp_Word16+   , WriteOffAddrOp_Int32    , WriteOffAddrOp_Word32+   , WriteOffAddrOp_Int64    , WriteOffAddrOp_Word64    , InterlockedExchange_Addr    , InterlockedExchange_Word@@ -557,6 +569,7 @@    , NewMutVarOp    , ReadMutVarOp    , WriteMutVarOp+   , AtomicSwapMutVarOp    , AtomicModifyMutVar2Op    , AtomicModifyMutVar_Op    , CasMutVarOp
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -324,6 +324,14 @@ primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo FloatFMAdd = mkGenPrimOp (fsLit "fmaddFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatFMSub = mkGenPrimOp (fsLit "fmsubFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatFNMAdd = mkGenPrimOp (fsLit "fnmaddFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatFNMSub = mkGenPrimOp (fsLit "fnmsubFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo DoubleFMAdd = mkGenPrimOp (fsLit "fmaddDouble#")  [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleFMSub = mkGenPrimOp (fsLit "fmsubDouble#")  [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleFNMAdd = mkGenPrimOp (fsLit "fnmaddDouble#")  [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleFNMSub = mkGenPrimOp (fsLit "fnmsubDouble#")  [] [doublePrimTy, doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy])) primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -378,12 +386,12 @@ primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (int8PrimTy)-primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)-primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (word8PrimTy)+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)@@ -394,10 +402,10 @@ primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))@@ -408,12 +416,12 @@ primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))-primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))-primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))@@ -424,10 +432,10 @@ primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -438,12 +446,12 @@ primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -454,18 +462,22 @@ primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayNonOverlappingOp = mkGenPrimOp (fsLit "copyMutableByteArrayNonOverlapping#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVarSpec] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyAddrToAddrOp = mkGenPrimOp (fsLit "copyAddrToAddr#")  [] [addrPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo CopyAddrToAddrNonOverlappingOp = mkGenPrimOp (fsLit "copyAddrToAddrNonOverlapping#")  [] [addrPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetAddrRangeOp = mkGenPrimOp (fsLit "setAddrRange#")  [] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -499,12 +511,12 @@ primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVarSpec] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (int8PrimTy)-primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16PrimTy)-primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (int32PrimTy)-primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (word8PrimTy)+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16PrimTy) primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (int32PrimTy) primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))@@ -515,12 +527,12 @@ primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVarSpec, alphaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))-primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))-primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))-primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy])) primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy])) primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -531,12 +543,12 @@ primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVarSpec, deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))@@ -557,6 +569,7 @@ primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy levPolyAlphaTy])) primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AtomicSwapMutVarOp = mkGenPrimOp (fsLit "atomicSwapMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVarSpec, alphaTyVarSpec, gammaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy])) primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))@@ -611,7 +624,7 @@ primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [levity2TyVarInf, levPolyBetaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, levPolyAlphaTy])) primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))-primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy levPolyAlphaTy])) primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStablePtrPrimTy levPolyAlphaTy] (intPrimTy)@@ -634,7 +647,7 @@ primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy)+primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy, (mkVisFunTyMany (mkStatePrimTy deltaTy) (openBetaTy))] (openBetaTy) primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVarSpec] [alphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVarSpec] [intPrimTy] (alphaTy) primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy]))
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -1,3 +1,5 @@+primOpStrictness AtomicModifyMutVar2Op =  \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv +primOpStrictness AtomicModifyMutVar_Op =  \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv  primOpStrictness CatchOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd                                                  , lazyApply2Dmd                                                  , topDmd] topDiv @@ -9,7 +11,7 @@ primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv  primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv  primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness PromptOp =  \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv +primOpStrictness PromptOp =  \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv  primOpStrictness Control0Op =  \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv  primOpStrictness AtomicallyOp =  \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv  primOpStrictness RetryOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1315 +1,1328 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1311-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 0-primOpTag CharGeOp = 1-primOpTag CharEqOp = 2-primOpTag CharNeOp = 3-primOpTag CharLtOp = 4-primOpTag CharLeOp = 5-primOpTag OrdOp = 6-primOpTag Int8ToIntOp = 7-primOpTag IntToInt8Op = 8-primOpTag Int8NegOp = 9-primOpTag Int8AddOp = 10-primOpTag Int8SubOp = 11-primOpTag Int8MulOp = 12-primOpTag Int8QuotOp = 13-primOpTag Int8RemOp = 14-primOpTag Int8QuotRemOp = 15-primOpTag Int8SllOp = 16-primOpTag Int8SraOp = 17-primOpTag Int8SrlOp = 18-primOpTag Int8ToWord8Op = 19-primOpTag Int8EqOp = 20-primOpTag Int8GeOp = 21-primOpTag Int8GtOp = 22-primOpTag Int8LeOp = 23-primOpTag Int8LtOp = 24-primOpTag Int8NeOp = 25-primOpTag Word8ToWordOp = 26-primOpTag WordToWord8Op = 27-primOpTag Word8AddOp = 28-primOpTag Word8SubOp = 29-primOpTag Word8MulOp = 30-primOpTag Word8QuotOp = 31-primOpTag Word8RemOp = 32-primOpTag Word8QuotRemOp = 33-primOpTag Word8AndOp = 34-primOpTag Word8OrOp = 35-primOpTag Word8XorOp = 36-primOpTag Word8NotOp = 37-primOpTag Word8SllOp = 38-primOpTag Word8SrlOp = 39-primOpTag Word8ToInt8Op = 40-primOpTag Word8EqOp = 41-primOpTag Word8GeOp = 42-primOpTag Word8GtOp = 43-primOpTag Word8LeOp = 44-primOpTag Word8LtOp = 45-primOpTag Word8NeOp = 46-primOpTag Int16ToIntOp = 47-primOpTag IntToInt16Op = 48-primOpTag Int16NegOp = 49-primOpTag Int16AddOp = 50-primOpTag Int16SubOp = 51-primOpTag Int16MulOp = 52-primOpTag Int16QuotOp = 53-primOpTag Int16RemOp = 54-primOpTag Int16QuotRemOp = 55-primOpTag Int16SllOp = 56-primOpTag Int16SraOp = 57-primOpTag Int16SrlOp = 58-primOpTag Int16ToWord16Op = 59-primOpTag Int16EqOp = 60-primOpTag Int16GeOp = 61-primOpTag Int16GtOp = 62-primOpTag Int16LeOp = 63-primOpTag Int16LtOp = 64-primOpTag Int16NeOp = 65-primOpTag Word16ToWordOp = 66-primOpTag WordToWord16Op = 67-primOpTag Word16AddOp = 68-primOpTag Word16SubOp = 69-primOpTag Word16MulOp = 70-primOpTag Word16QuotOp = 71-primOpTag Word16RemOp = 72-primOpTag Word16QuotRemOp = 73-primOpTag Word16AndOp = 74-primOpTag Word16OrOp = 75-primOpTag Word16XorOp = 76-primOpTag Word16NotOp = 77-primOpTag Word16SllOp = 78-primOpTag Word16SrlOp = 79-primOpTag Word16ToInt16Op = 80-primOpTag Word16EqOp = 81-primOpTag Word16GeOp = 82-primOpTag Word16GtOp = 83-primOpTag Word16LeOp = 84-primOpTag Word16LtOp = 85-primOpTag Word16NeOp = 86-primOpTag Int32ToIntOp = 87-primOpTag IntToInt32Op = 88-primOpTag Int32NegOp = 89-primOpTag Int32AddOp = 90-primOpTag Int32SubOp = 91-primOpTag Int32MulOp = 92-primOpTag Int32QuotOp = 93-primOpTag Int32RemOp = 94-primOpTag Int32QuotRemOp = 95-primOpTag Int32SllOp = 96-primOpTag Int32SraOp = 97-primOpTag Int32SrlOp = 98-primOpTag Int32ToWord32Op = 99-primOpTag Int32EqOp = 100-primOpTag Int32GeOp = 101-primOpTag Int32GtOp = 102-primOpTag Int32LeOp = 103-primOpTag Int32LtOp = 104-primOpTag Int32NeOp = 105-primOpTag Word32ToWordOp = 106-primOpTag WordToWord32Op = 107-primOpTag Word32AddOp = 108-primOpTag Word32SubOp = 109-primOpTag Word32MulOp = 110-primOpTag Word32QuotOp = 111-primOpTag Word32RemOp = 112-primOpTag Word32QuotRemOp = 113-primOpTag Word32AndOp = 114-primOpTag Word32OrOp = 115-primOpTag Word32XorOp = 116-primOpTag Word32NotOp = 117-primOpTag Word32SllOp = 118-primOpTag Word32SrlOp = 119-primOpTag Word32ToInt32Op = 120-primOpTag Word32EqOp = 121-primOpTag Word32GeOp = 122-primOpTag Word32GtOp = 123-primOpTag Word32LeOp = 124-primOpTag Word32LtOp = 125-primOpTag Word32NeOp = 126-primOpTag Int64ToIntOp = 127-primOpTag IntToInt64Op = 128-primOpTag Int64NegOp = 129-primOpTag Int64AddOp = 130-primOpTag Int64SubOp = 131-primOpTag Int64MulOp = 132-primOpTag Int64QuotOp = 133-primOpTag Int64RemOp = 134-primOpTag Int64SllOp = 135-primOpTag Int64SraOp = 136-primOpTag Int64SrlOp = 137-primOpTag Int64ToWord64Op = 138-primOpTag Int64EqOp = 139-primOpTag Int64GeOp = 140-primOpTag Int64GtOp = 141-primOpTag Int64LeOp = 142-primOpTag Int64LtOp = 143-primOpTag Int64NeOp = 144-primOpTag Word64ToWordOp = 145-primOpTag WordToWord64Op = 146-primOpTag Word64AddOp = 147-primOpTag Word64SubOp = 148-primOpTag Word64MulOp = 149-primOpTag Word64QuotOp = 150-primOpTag Word64RemOp = 151-primOpTag Word64AndOp = 152-primOpTag Word64OrOp = 153-primOpTag Word64XorOp = 154-primOpTag Word64NotOp = 155-primOpTag Word64SllOp = 156-primOpTag Word64SrlOp = 157-primOpTag Word64ToInt64Op = 158-primOpTag Word64EqOp = 159-primOpTag Word64GeOp = 160-primOpTag Word64GtOp = 161-primOpTag Word64LeOp = 162-primOpTag Word64LtOp = 163-primOpTag Word64NeOp = 164-primOpTag IntAddOp = 165-primOpTag IntSubOp = 166-primOpTag IntMulOp = 167-primOpTag IntMul2Op = 168-primOpTag IntMulMayOfloOp = 169-primOpTag IntQuotOp = 170-primOpTag IntRemOp = 171-primOpTag IntQuotRemOp = 172-primOpTag IntAndOp = 173-primOpTag IntOrOp = 174-primOpTag IntXorOp = 175-primOpTag IntNotOp = 176-primOpTag IntNegOp = 177-primOpTag IntAddCOp = 178-primOpTag IntSubCOp = 179-primOpTag IntGtOp = 180-primOpTag IntGeOp = 181-primOpTag IntEqOp = 182-primOpTag IntNeOp = 183-primOpTag IntLtOp = 184-primOpTag IntLeOp = 185-primOpTag ChrOp = 186-primOpTag IntToWordOp = 187-primOpTag IntToFloatOp = 188-primOpTag IntToDoubleOp = 189-primOpTag WordToFloatOp = 190-primOpTag WordToDoubleOp = 191-primOpTag IntSllOp = 192-primOpTag IntSraOp = 193-primOpTag IntSrlOp = 194-primOpTag WordAddOp = 195-primOpTag WordAddCOp = 196-primOpTag WordSubCOp = 197-primOpTag WordAdd2Op = 198-primOpTag WordSubOp = 199-primOpTag WordMulOp = 200-primOpTag WordMul2Op = 201-primOpTag WordQuotOp = 202-primOpTag WordRemOp = 203-primOpTag WordQuotRemOp = 204-primOpTag WordQuotRem2Op = 205-primOpTag WordAndOp = 206-primOpTag WordOrOp = 207-primOpTag WordXorOp = 208-primOpTag WordNotOp = 209-primOpTag WordSllOp = 210-primOpTag WordSrlOp = 211-primOpTag WordToIntOp = 212-primOpTag WordGtOp = 213-primOpTag WordGeOp = 214-primOpTag WordEqOp = 215-primOpTag WordNeOp = 216-primOpTag WordLtOp = 217-primOpTag WordLeOp = 218-primOpTag PopCnt8Op = 219-primOpTag PopCnt16Op = 220-primOpTag PopCnt32Op = 221-primOpTag PopCnt64Op = 222-primOpTag PopCntOp = 223-primOpTag Pdep8Op = 224-primOpTag Pdep16Op = 225-primOpTag Pdep32Op = 226-primOpTag Pdep64Op = 227-primOpTag PdepOp = 228-primOpTag Pext8Op = 229-primOpTag Pext16Op = 230-primOpTag Pext32Op = 231-primOpTag Pext64Op = 232-primOpTag PextOp = 233-primOpTag Clz8Op = 234-primOpTag Clz16Op = 235-primOpTag Clz32Op = 236-primOpTag Clz64Op = 237-primOpTag ClzOp = 238-primOpTag Ctz8Op = 239-primOpTag Ctz16Op = 240-primOpTag Ctz32Op = 241-primOpTag Ctz64Op = 242-primOpTag CtzOp = 243-primOpTag BSwap16Op = 244-primOpTag BSwap32Op = 245-primOpTag BSwap64Op = 246-primOpTag BSwapOp = 247-primOpTag BRev8Op = 248-primOpTag BRev16Op = 249-primOpTag BRev32Op = 250-primOpTag BRev64Op = 251-primOpTag BRevOp = 252-primOpTag Narrow8IntOp = 253-primOpTag Narrow16IntOp = 254-primOpTag Narrow32IntOp = 255-primOpTag Narrow8WordOp = 256-primOpTag Narrow16WordOp = 257-primOpTag Narrow32WordOp = 258-primOpTag DoubleGtOp = 259-primOpTag DoubleGeOp = 260-primOpTag DoubleEqOp = 261-primOpTag DoubleNeOp = 262-primOpTag DoubleLtOp = 263-primOpTag DoubleLeOp = 264-primOpTag DoubleAddOp = 265-primOpTag DoubleSubOp = 266-primOpTag DoubleMulOp = 267-primOpTag DoubleDivOp = 268-primOpTag DoubleNegOp = 269-primOpTag DoubleFabsOp = 270-primOpTag DoubleToIntOp = 271-primOpTag DoubleToFloatOp = 272-primOpTag DoubleExpOp = 273-primOpTag DoubleExpM1Op = 274-primOpTag DoubleLogOp = 275-primOpTag DoubleLog1POp = 276-primOpTag DoubleSqrtOp = 277-primOpTag DoubleSinOp = 278-primOpTag DoubleCosOp = 279-primOpTag DoubleTanOp = 280-primOpTag DoubleAsinOp = 281-primOpTag DoubleAcosOp = 282-primOpTag DoubleAtanOp = 283-primOpTag DoubleSinhOp = 284-primOpTag DoubleCoshOp = 285-primOpTag DoubleTanhOp = 286-primOpTag DoubleAsinhOp = 287-primOpTag DoubleAcoshOp = 288-primOpTag DoubleAtanhOp = 289-primOpTag DoublePowerOp = 290-primOpTag DoubleDecode_2IntOp = 291-primOpTag DoubleDecode_Int64Op = 292-primOpTag FloatGtOp = 293-primOpTag FloatGeOp = 294-primOpTag FloatEqOp = 295-primOpTag FloatNeOp = 296-primOpTag FloatLtOp = 297-primOpTag FloatLeOp = 298-primOpTag FloatAddOp = 299-primOpTag FloatSubOp = 300-primOpTag FloatMulOp = 301-primOpTag FloatDivOp = 302-primOpTag FloatNegOp = 303-primOpTag FloatFabsOp = 304-primOpTag FloatToIntOp = 305-primOpTag FloatExpOp = 306-primOpTag FloatExpM1Op = 307-primOpTag FloatLogOp = 308-primOpTag FloatLog1POp = 309-primOpTag FloatSqrtOp = 310-primOpTag FloatSinOp = 311-primOpTag FloatCosOp = 312-primOpTag FloatTanOp = 313-primOpTag FloatAsinOp = 314-primOpTag FloatAcosOp = 315-primOpTag FloatAtanOp = 316-primOpTag FloatSinhOp = 317-primOpTag FloatCoshOp = 318-primOpTag FloatTanhOp = 319-primOpTag FloatAsinhOp = 320-primOpTag FloatAcoshOp = 321-primOpTag FloatAtanhOp = 322-primOpTag FloatPowerOp = 323-primOpTag FloatToDoubleOp = 324-primOpTag FloatDecode_IntOp = 325-primOpTag NewArrayOp = 326-primOpTag ReadArrayOp = 327-primOpTag WriteArrayOp = 328-primOpTag SizeofArrayOp = 329-primOpTag SizeofMutableArrayOp = 330-primOpTag IndexArrayOp = 331-primOpTag UnsafeFreezeArrayOp = 332-primOpTag UnsafeThawArrayOp = 333-primOpTag CopyArrayOp = 334-primOpTag CopyMutableArrayOp = 335-primOpTag CloneArrayOp = 336-primOpTag CloneMutableArrayOp = 337-primOpTag FreezeArrayOp = 338-primOpTag ThawArrayOp = 339-primOpTag CasArrayOp = 340-primOpTag NewSmallArrayOp = 341-primOpTag ShrinkSmallMutableArrayOp_Char = 342-primOpTag ReadSmallArrayOp = 343-primOpTag WriteSmallArrayOp = 344-primOpTag SizeofSmallArrayOp = 345-primOpTag SizeofSmallMutableArrayOp = 346-primOpTag GetSizeofSmallMutableArrayOp = 347-primOpTag IndexSmallArrayOp = 348-primOpTag UnsafeFreezeSmallArrayOp = 349-primOpTag UnsafeThawSmallArrayOp = 350-primOpTag CopySmallArrayOp = 351-primOpTag CopySmallMutableArrayOp = 352-primOpTag CloneSmallArrayOp = 353-primOpTag CloneSmallMutableArrayOp = 354-primOpTag FreezeSmallArrayOp = 355-primOpTag ThawSmallArrayOp = 356-primOpTag CasSmallArrayOp = 357-primOpTag NewByteArrayOp_Char = 358-primOpTag NewPinnedByteArrayOp_Char = 359-primOpTag NewAlignedPinnedByteArrayOp_Char = 360-primOpTag MutableByteArrayIsPinnedOp = 361-primOpTag ByteArrayIsPinnedOp = 362-primOpTag ByteArrayContents_Char = 363-primOpTag MutableByteArrayContents_Char = 364-primOpTag ShrinkMutableByteArrayOp_Char = 365-primOpTag ResizeMutableByteArrayOp_Char = 366-primOpTag UnsafeFreezeByteArrayOp = 367-primOpTag SizeofByteArrayOp = 368-primOpTag SizeofMutableByteArrayOp = 369-primOpTag GetSizeofMutableByteArrayOp = 370-primOpTag IndexByteArrayOp_Char = 371-primOpTag IndexByteArrayOp_WideChar = 372-primOpTag IndexByteArrayOp_Int = 373-primOpTag IndexByteArrayOp_Word = 374-primOpTag IndexByteArrayOp_Addr = 375-primOpTag IndexByteArrayOp_Float = 376-primOpTag IndexByteArrayOp_Double = 377-primOpTag IndexByteArrayOp_StablePtr = 378-primOpTag IndexByteArrayOp_Int8 = 379-primOpTag IndexByteArrayOp_Int16 = 380-primOpTag IndexByteArrayOp_Int32 = 381-primOpTag IndexByteArrayOp_Int64 = 382-primOpTag IndexByteArrayOp_Word8 = 383-primOpTag IndexByteArrayOp_Word16 = 384-primOpTag IndexByteArrayOp_Word32 = 385-primOpTag IndexByteArrayOp_Word64 = 386-primOpTag IndexByteArrayOp_Word8AsChar = 387-primOpTag IndexByteArrayOp_Word8AsWideChar = 388-primOpTag IndexByteArrayOp_Word8AsInt = 389-primOpTag IndexByteArrayOp_Word8AsWord = 390-primOpTag IndexByteArrayOp_Word8AsAddr = 391-primOpTag IndexByteArrayOp_Word8AsFloat = 392-primOpTag IndexByteArrayOp_Word8AsDouble = 393-primOpTag IndexByteArrayOp_Word8AsStablePtr = 394-primOpTag IndexByteArrayOp_Word8AsInt16 = 395-primOpTag IndexByteArrayOp_Word8AsInt32 = 396-primOpTag IndexByteArrayOp_Word8AsInt64 = 397-primOpTag IndexByteArrayOp_Word8AsWord16 = 398-primOpTag IndexByteArrayOp_Word8AsWord32 = 399-primOpTag IndexByteArrayOp_Word8AsWord64 = 400-primOpTag ReadByteArrayOp_Char = 401-primOpTag ReadByteArrayOp_WideChar = 402-primOpTag ReadByteArrayOp_Int = 403-primOpTag ReadByteArrayOp_Word = 404-primOpTag ReadByteArrayOp_Addr = 405-primOpTag ReadByteArrayOp_Float = 406-primOpTag ReadByteArrayOp_Double = 407-primOpTag ReadByteArrayOp_StablePtr = 408-primOpTag ReadByteArrayOp_Int8 = 409-primOpTag ReadByteArrayOp_Int16 = 410-primOpTag ReadByteArrayOp_Int32 = 411-primOpTag ReadByteArrayOp_Int64 = 412-primOpTag ReadByteArrayOp_Word8 = 413-primOpTag ReadByteArrayOp_Word16 = 414-primOpTag ReadByteArrayOp_Word32 = 415-primOpTag ReadByteArrayOp_Word64 = 416-primOpTag ReadByteArrayOp_Word8AsChar = 417-primOpTag ReadByteArrayOp_Word8AsWideChar = 418-primOpTag ReadByteArrayOp_Word8AsInt = 419-primOpTag ReadByteArrayOp_Word8AsWord = 420-primOpTag ReadByteArrayOp_Word8AsAddr = 421-primOpTag ReadByteArrayOp_Word8AsFloat = 422-primOpTag ReadByteArrayOp_Word8AsDouble = 423-primOpTag ReadByteArrayOp_Word8AsStablePtr = 424-primOpTag ReadByteArrayOp_Word8AsInt16 = 425-primOpTag ReadByteArrayOp_Word8AsInt32 = 426-primOpTag ReadByteArrayOp_Word8AsInt64 = 427-primOpTag ReadByteArrayOp_Word8AsWord16 = 428-primOpTag ReadByteArrayOp_Word8AsWord32 = 429-primOpTag ReadByteArrayOp_Word8AsWord64 = 430-primOpTag WriteByteArrayOp_Char = 431-primOpTag WriteByteArrayOp_WideChar = 432-primOpTag WriteByteArrayOp_Int = 433-primOpTag WriteByteArrayOp_Word = 434-primOpTag WriteByteArrayOp_Addr = 435-primOpTag WriteByteArrayOp_Float = 436-primOpTag WriteByteArrayOp_Double = 437-primOpTag WriteByteArrayOp_StablePtr = 438-primOpTag WriteByteArrayOp_Int8 = 439-primOpTag WriteByteArrayOp_Int16 = 440-primOpTag WriteByteArrayOp_Int32 = 441-primOpTag WriteByteArrayOp_Int64 = 442-primOpTag WriteByteArrayOp_Word8 = 443-primOpTag WriteByteArrayOp_Word16 = 444-primOpTag WriteByteArrayOp_Word32 = 445-primOpTag WriteByteArrayOp_Word64 = 446-primOpTag WriteByteArrayOp_Word8AsChar = 447-primOpTag WriteByteArrayOp_Word8AsWideChar = 448-primOpTag WriteByteArrayOp_Word8AsInt = 449-primOpTag WriteByteArrayOp_Word8AsWord = 450-primOpTag WriteByteArrayOp_Word8AsAddr = 451-primOpTag WriteByteArrayOp_Word8AsFloat = 452-primOpTag WriteByteArrayOp_Word8AsDouble = 453-primOpTag WriteByteArrayOp_Word8AsStablePtr = 454-primOpTag WriteByteArrayOp_Word8AsInt16 = 455-primOpTag WriteByteArrayOp_Word8AsInt32 = 456-primOpTag WriteByteArrayOp_Word8AsInt64 = 457-primOpTag WriteByteArrayOp_Word8AsWord16 = 458-primOpTag WriteByteArrayOp_Word8AsWord32 = 459-primOpTag WriteByteArrayOp_Word8AsWord64 = 460-primOpTag CompareByteArraysOp = 461-primOpTag CopyByteArrayOp = 462-primOpTag CopyMutableByteArrayOp = 463-primOpTag CopyByteArrayToAddrOp = 464-primOpTag CopyMutableByteArrayToAddrOp = 465-primOpTag CopyAddrToByteArrayOp = 466-primOpTag SetByteArrayOp = 467-primOpTag AtomicReadByteArrayOp_Int = 468-primOpTag AtomicWriteByteArrayOp_Int = 469-primOpTag CasByteArrayOp_Int = 470-primOpTag CasByteArrayOp_Int8 = 471-primOpTag CasByteArrayOp_Int16 = 472-primOpTag CasByteArrayOp_Int32 = 473-primOpTag CasByteArrayOp_Int64 = 474-primOpTag FetchAddByteArrayOp_Int = 475-primOpTag FetchSubByteArrayOp_Int = 476-primOpTag FetchAndByteArrayOp_Int = 477-primOpTag FetchNandByteArrayOp_Int = 478-primOpTag FetchOrByteArrayOp_Int = 479-primOpTag FetchXorByteArrayOp_Int = 480-primOpTag AddrAddOp = 481-primOpTag AddrSubOp = 482-primOpTag AddrRemOp = 483-primOpTag AddrToIntOp = 484-primOpTag IntToAddrOp = 485-primOpTag AddrGtOp = 486-primOpTag AddrGeOp = 487-primOpTag AddrEqOp = 488-primOpTag AddrNeOp = 489-primOpTag AddrLtOp = 490-primOpTag AddrLeOp = 491-primOpTag IndexOffAddrOp_Char = 492-primOpTag IndexOffAddrOp_WideChar = 493-primOpTag IndexOffAddrOp_Int = 494-primOpTag IndexOffAddrOp_Word = 495-primOpTag IndexOffAddrOp_Addr = 496-primOpTag IndexOffAddrOp_Float = 497-primOpTag IndexOffAddrOp_Double = 498-primOpTag IndexOffAddrOp_StablePtr = 499-primOpTag IndexOffAddrOp_Int8 = 500-primOpTag IndexOffAddrOp_Int16 = 501-primOpTag IndexOffAddrOp_Int32 = 502-primOpTag IndexOffAddrOp_Int64 = 503-primOpTag IndexOffAddrOp_Word8 = 504-primOpTag IndexOffAddrOp_Word16 = 505-primOpTag IndexOffAddrOp_Word32 = 506-primOpTag IndexOffAddrOp_Word64 = 507-primOpTag ReadOffAddrOp_Char = 508-primOpTag ReadOffAddrOp_WideChar = 509-primOpTag ReadOffAddrOp_Int = 510-primOpTag ReadOffAddrOp_Word = 511-primOpTag ReadOffAddrOp_Addr = 512-primOpTag ReadOffAddrOp_Float = 513-primOpTag ReadOffAddrOp_Double = 514-primOpTag ReadOffAddrOp_StablePtr = 515-primOpTag ReadOffAddrOp_Int8 = 516-primOpTag ReadOffAddrOp_Int16 = 517-primOpTag ReadOffAddrOp_Int32 = 518-primOpTag ReadOffAddrOp_Int64 = 519-primOpTag ReadOffAddrOp_Word8 = 520-primOpTag ReadOffAddrOp_Word16 = 521-primOpTag ReadOffAddrOp_Word32 = 522-primOpTag ReadOffAddrOp_Word64 = 523-primOpTag WriteOffAddrOp_Char = 524-primOpTag WriteOffAddrOp_WideChar = 525-primOpTag WriteOffAddrOp_Int = 526-primOpTag WriteOffAddrOp_Word = 527-primOpTag WriteOffAddrOp_Addr = 528-primOpTag WriteOffAddrOp_Float = 529-primOpTag WriteOffAddrOp_Double = 530-primOpTag WriteOffAddrOp_StablePtr = 531-primOpTag WriteOffAddrOp_Int8 = 532-primOpTag WriteOffAddrOp_Int16 = 533-primOpTag WriteOffAddrOp_Int32 = 534-primOpTag WriteOffAddrOp_Int64 = 535-primOpTag WriteOffAddrOp_Word8 = 536-primOpTag WriteOffAddrOp_Word16 = 537-primOpTag WriteOffAddrOp_Word32 = 538-primOpTag WriteOffAddrOp_Word64 = 539-primOpTag InterlockedExchange_Addr = 540-primOpTag InterlockedExchange_Word = 541-primOpTag CasAddrOp_Addr = 542-primOpTag CasAddrOp_Word = 543-primOpTag CasAddrOp_Word8 = 544-primOpTag CasAddrOp_Word16 = 545-primOpTag CasAddrOp_Word32 = 546-primOpTag CasAddrOp_Word64 = 547-primOpTag FetchAddAddrOp_Word = 548-primOpTag FetchSubAddrOp_Word = 549-primOpTag FetchAndAddrOp_Word = 550-primOpTag FetchNandAddrOp_Word = 551-primOpTag FetchOrAddrOp_Word = 552-primOpTag FetchXorAddrOp_Word = 553-primOpTag AtomicReadAddrOp_Word = 554-primOpTag AtomicWriteAddrOp_Word = 555-primOpTag NewMutVarOp = 556-primOpTag ReadMutVarOp = 557-primOpTag WriteMutVarOp = 558-primOpTag AtomicModifyMutVar2Op = 559-primOpTag AtomicModifyMutVar_Op = 560-primOpTag CasMutVarOp = 561-primOpTag CatchOp = 562-primOpTag RaiseOp = 563-primOpTag RaiseUnderflowOp = 564-primOpTag RaiseOverflowOp = 565-primOpTag RaiseDivZeroOp = 566-primOpTag RaiseIOOp = 567-primOpTag MaskAsyncExceptionsOp = 568-primOpTag MaskUninterruptibleOp = 569-primOpTag UnmaskAsyncExceptionsOp = 570-primOpTag MaskStatus = 571-primOpTag NewPromptTagOp = 572-primOpTag PromptOp = 573-primOpTag Control0Op = 574-primOpTag AtomicallyOp = 575-primOpTag RetryOp = 576-primOpTag CatchRetryOp = 577-primOpTag CatchSTMOp = 578-primOpTag NewTVarOp = 579-primOpTag ReadTVarOp = 580-primOpTag ReadTVarIOOp = 581-primOpTag WriteTVarOp = 582-primOpTag NewMVarOp = 583-primOpTag TakeMVarOp = 584-primOpTag TryTakeMVarOp = 585-primOpTag PutMVarOp = 586-primOpTag TryPutMVarOp = 587-primOpTag ReadMVarOp = 588-primOpTag TryReadMVarOp = 589-primOpTag IsEmptyMVarOp = 590-primOpTag NewIOPortOp = 591-primOpTag ReadIOPortOp = 592-primOpTag WriteIOPortOp = 593-primOpTag DelayOp = 594-primOpTag WaitReadOp = 595-primOpTag WaitWriteOp = 596-primOpTag ForkOp = 597-primOpTag ForkOnOp = 598-primOpTag KillThreadOp = 599-primOpTag YieldOp = 600-primOpTag MyThreadIdOp = 601-primOpTag LabelThreadOp = 602-primOpTag IsCurrentThreadBoundOp = 603-primOpTag NoDuplicateOp = 604-primOpTag GetThreadLabelOp = 605-primOpTag ThreadStatusOp = 606-primOpTag ListThreadsOp = 607-primOpTag MkWeakOp = 608-primOpTag MkWeakNoFinalizerOp = 609-primOpTag AddCFinalizerToWeakOp = 610-primOpTag DeRefWeakOp = 611-primOpTag FinalizeWeakOp = 612-primOpTag TouchOp = 613-primOpTag MakeStablePtrOp = 614-primOpTag DeRefStablePtrOp = 615-primOpTag EqStablePtrOp = 616-primOpTag MakeStableNameOp = 617-primOpTag StableNameToIntOp = 618-primOpTag CompactNewOp = 619-primOpTag CompactResizeOp = 620-primOpTag CompactContainsOp = 621-primOpTag CompactContainsAnyOp = 622-primOpTag CompactGetFirstBlockOp = 623-primOpTag CompactGetNextBlockOp = 624-primOpTag CompactAllocateBlockOp = 625-primOpTag CompactFixupPointersOp = 626-primOpTag CompactAdd = 627-primOpTag CompactAddWithSharing = 628-primOpTag CompactSize = 629-primOpTag ReallyUnsafePtrEqualityOp = 630-primOpTag ParOp = 631-primOpTag SparkOp = 632-primOpTag SeqOp = 633-primOpTag GetSparkOp = 634-primOpTag NumSparks = 635-primOpTag KeepAliveOp = 636-primOpTag DataToTagOp = 637-primOpTag TagToEnumOp = 638-primOpTag AddrToAnyOp = 639-primOpTag AnyToAddrOp = 640-primOpTag MkApUpd0_Op = 641-primOpTag NewBCOOp = 642-primOpTag UnpackClosureOp = 643-primOpTag ClosureSizeOp = 644-primOpTag GetApStackValOp = 645-primOpTag GetCCSOfOp = 646-primOpTag GetCurrentCCSOp = 647-primOpTag ClearCCSOp = 648-primOpTag WhereFromOp = 649-primOpTag TraceEventOp = 650-primOpTag TraceEventBinaryOp = 651-primOpTag TraceMarkerOp = 652-primOpTag SetThreadAllocationCounter = 653-primOpTag (VecBroadcastOp IntVec 16 W8) = 654-primOpTag (VecBroadcastOp IntVec 8 W16) = 655-primOpTag (VecBroadcastOp IntVec 4 W32) = 656-primOpTag (VecBroadcastOp IntVec 2 W64) = 657-primOpTag (VecBroadcastOp IntVec 32 W8) = 658-primOpTag (VecBroadcastOp IntVec 16 W16) = 659-primOpTag (VecBroadcastOp IntVec 8 W32) = 660-primOpTag (VecBroadcastOp IntVec 4 W64) = 661-primOpTag (VecBroadcastOp IntVec 64 W8) = 662-primOpTag (VecBroadcastOp IntVec 32 W16) = 663-primOpTag (VecBroadcastOp IntVec 16 W32) = 664-primOpTag (VecBroadcastOp IntVec 8 W64) = 665-primOpTag (VecBroadcastOp WordVec 16 W8) = 666-primOpTag (VecBroadcastOp WordVec 8 W16) = 667-primOpTag (VecBroadcastOp WordVec 4 W32) = 668-primOpTag (VecBroadcastOp WordVec 2 W64) = 669-primOpTag (VecBroadcastOp WordVec 32 W8) = 670-primOpTag (VecBroadcastOp WordVec 16 W16) = 671-primOpTag (VecBroadcastOp WordVec 8 W32) = 672-primOpTag (VecBroadcastOp WordVec 4 W64) = 673-primOpTag (VecBroadcastOp WordVec 64 W8) = 674-primOpTag (VecBroadcastOp WordVec 32 W16) = 675-primOpTag (VecBroadcastOp WordVec 16 W32) = 676-primOpTag (VecBroadcastOp WordVec 8 W64) = 677-primOpTag (VecBroadcastOp FloatVec 4 W32) = 678-primOpTag (VecBroadcastOp FloatVec 2 W64) = 679-primOpTag (VecBroadcastOp FloatVec 8 W32) = 680-primOpTag (VecBroadcastOp FloatVec 4 W64) = 681-primOpTag (VecBroadcastOp FloatVec 16 W32) = 682-primOpTag (VecBroadcastOp FloatVec 8 W64) = 683-primOpTag (VecPackOp IntVec 16 W8) = 684-primOpTag (VecPackOp IntVec 8 W16) = 685-primOpTag (VecPackOp IntVec 4 W32) = 686-primOpTag (VecPackOp IntVec 2 W64) = 687-primOpTag (VecPackOp IntVec 32 W8) = 688-primOpTag (VecPackOp IntVec 16 W16) = 689-primOpTag (VecPackOp IntVec 8 W32) = 690-primOpTag (VecPackOp IntVec 4 W64) = 691-primOpTag (VecPackOp IntVec 64 W8) = 692-primOpTag (VecPackOp IntVec 32 W16) = 693-primOpTag (VecPackOp IntVec 16 W32) = 694-primOpTag (VecPackOp IntVec 8 W64) = 695-primOpTag (VecPackOp WordVec 16 W8) = 696-primOpTag (VecPackOp WordVec 8 W16) = 697-primOpTag (VecPackOp WordVec 4 W32) = 698-primOpTag (VecPackOp WordVec 2 W64) = 699-primOpTag (VecPackOp WordVec 32 W8) = 700-primOpTag (VecPackOp WordVec 16 W16) = 701-primOpTag (VecPackOp WordVec 8 W32) = 702-primOpTag (VecPackOp WordVec 4 W64) = 703-primOpTag (VecPackOp WordVec 64 W8) = 704-primOpTag (VecPackOp WordVec 32 W16) = 705-primOpTag (VecPackOp WordVec 16 W32) = 706-primOpTag (VecPackOp WordVec 8 W64) = 707-primOpTag (VecPackOp FloatVec 4 W32) = 708-primOpTag (VecPackOp FloatVec 2 W64) = 709-primOpTag (VecPackOp FloatVec 8 W32) = 710-primOpTag (VecPackOp FloatVec 4 W64) = 711-primOpTag (VecPackOp FloatVec 16 W32) = 712-primOpTag (VecPackOp FloatVec 8 W64) = 713-primOpTag (VecUnpackOp IntVec 16 W8) = 714-primOpTag (VecUnpackOp IntVec 8 W16) = 715-primOpTag (VecUnpackOp IntVec 4 W32) = 716-primOpTag (VecUnpackOp IntVec 2 W64) = 717-primOpTag (VecUnpackOp IntVec 32 W8) = 718-primOpTag (VecUnpackOp IntVec 16 W16) = 719-primOpTag (VecUnpackOp IntVec 8 W32) = 720-primOpTag (VecUnpackOp IntVec 4 W64) = 721-primOpTag (VecUnpackOp IntVec 64 W8) = 722-primOpTag (VecUnpackOp IntVec 32 W16) = 723-primOpTag (VecUnpackOp IntVec 16 W32) = 724-primOpTag (VecUnpackOp IntVec 8 W64) = 725-primOpTag (VecUnpackOp WordVec 16 W8) = 726-primOpTag (VecUnpackOp WordVec 8 W16) = 727-primOpTag (VecUnpackOp WordVec 4 W32) = 728-primOpTag (VecUnpackOp WordVec 2 W64) = 729-primOpTag (VecUnpackOp WordVec 32 W8) = 730-primOpTag (VecUnpackOp WordVec 16 W16) = 731-primOpTag (VecUnpackOp WordVec 8 W32) = 732-primOpTag (VecUnpackOp WordVec 4 W64) = 733-primOpTag (VecUnpackOp WordVec 64 W8) = 734-primOpTag (VecUnpackOp WordVec 32 W16) = 735-primOpTag (VecUnpackOp WordVec 16 W32) = 736-primOpTag (VecUnpackOp WordVec 8 W64) = 737-primOpTag (VecUnpackOp FloatVec 4 W32) = 738-primOpTag (VecUnpackOp FloatVec 2 W64) = 739-primOpTag (VecUnpackOp FloatVec 8 W32) = 740-primOpTag (VecUnpackOp FloatVec 4 W64) = 741-primOpTag (VecUnpackOp FloatVec 16 W32) = 742-primOpTag (VecUnpackOp FloatVec 8 W64) = 743-primOpTag (VecInsertOp IntVec 16 W8) = 744-primOpTag (VecInsertOp IntVec 8 W16) = 745-primOpTag (VecInsertOp IntVec 4 W32) = 746-primOpTag (VecInsertOp IntVec 2 W64) = 747-primOpTag (VecInsertOp IntVec 32 W8) = 748-primOpTag (VecInsertOp IntVec 16 W16) = 749-primOpTag (VecInsertOp IntVec 8 W32) = 750-primOpTag (VecInsertOp IntVec 4 W64) = 751-primOpTag (VecInsertOp IntVec 64 W8) = 752-primOpTag (VecInsertOp IntVec 32 W16) = 753-primOpTag (VecInsertOp IntVec 16 W32) = 754-primOpTag (VecInsertOp IntVec 8 W64) = 755-primOpTag (VecInsertOp WordVec 16 W8) = 756-primOpTag (VecInsertOp WordVec 8 W16) = 757-primOpTag (VecInsertOp WordVec 4 W32) = 758-primOpTag (VecInsertOp WordVec 2 W64) = 759-primOpTag (VecInsertOp WordVec 32 W8) = 760-primOpTag (VecInsertOp WordVec 16 W16) = 761-primOpTag (VecInsertOp WordVec 8 W32) = 762-primOpTag (VecInsertOp WordVec 4 W64) = 763-primOpTag (VecInsertOp WordVec 64 W8) = 764-primOpTag (VecInsertOp WordVec 32 W16) = 765-primOpTag (VecInsertOp WordVec 16 W32) = 766-primOpTag (VecInsertOp WordVec 8 W64) = 767-primOpTag (VecInsertOp FloatVec 4 W32) = 768-primOpTag (VecInsertOp FloatVec 2 W64) = 769-primOpTag (VecInsertOp FloatVec 8 W32) = 770-primOpTag (VecInsertOp FloatVec 4 W64) = 771-primOpTag (VecInsertOp FloatVec 16 W32) = 772-primOpTag (VecInsertOp FloatVec 8 W64) = 773-primOpTag (VecAddOp IntVec 16 W8) = 774-primOpTag (VecAddOp IntVec 8 W16) = 775-primOpTag (VecAddOp IntVec 4 W32) = 776-primOpTag (VecAddOp IntVec 2 W64) = 777-primOpTag (VecAddOp IntVec 32 W8) = 778-primOpTag (VecAddOp IntVec 16 W16) = 779-primOpTag (VecAddOp IntVec 8 W32) = 780-primOpTag (VecAddOp IntVec 4 W64) = 781-primOpTag (VecAddOp IntVec 64 W8) = 782-primOpTag (VecAddOp IntVec 32 W16) = 783-primOpTag (VecAddOp IntVec 16 W32) = 784-primOpTag (VecAddOp IntVec 8 W64) = 785-primOpTag (VecAddOp WordVec 16 W8) = 786-primOpTag (VecAddOp WordVec 8 W16) = 787-primOpTag (VecAddOp WordVec 4 W32) = 788-primOpTag (VecAddOp WordVec 2 W64) = 789-primOpTag (VecAddOp WordVec 32 W8) = 790-primOpTag (VecAddOp WordVec 16 W16) = 791-primOpTag (VecAddOp WordVec 8 W32) = 792-primOpTag (VecAddOp WordVec 4 W64) = 793-primOpTag (VecAddOp WordVec 64 W8) = 794-primOpTag (VecAddOp WordVec 32 W16) = 795-primOpTag (VecAddOp WordVec 16 W32) = 796-primOpTag (VecAddOp WordVec 8 W64) = 797-primOpTag (VecAddOp FloatVec 4 W32) = 798-primOpTag (VecAddOp FloatVec 2 W64) = 799-primOpTag (VecAddOp FloatVec 8 W32) = 800-primOpTag (VecAddOp FloatVec 4 W64) = 801-primOpTag (VecAddOp FloatVec 16 W32) = 802-primOpTag (VecAddOp FloatVec 8 W64) = 803-primOpTag (VecSubOp IntVec 16 W8) = 804-primOpTag (VecSubOp IntVec 8 W16) = 805-primOpTag (VecSubOp IntVec 4 W32) = 806-primOpTag (VecSubOp IntVec 2 W64) = 807-primOpTag (VecSubOp IntVec 32 W8) = 808-primOpTag (VecSubOp IntVec 16 W16) = 809-primOpTag (VecSubOp IntVec 8 W32) = 810-primOpTag (VecSubOp IntVec 4 W64) = 811-primOpTag (VecSubOp IntVec 64 W8) = 812-primOpTag (VecSubOp IntVec 32 W16) = 813-primOpTag (VecSubOp IntVec 16 W32) = 814-primOpTag (VecSubOp IntVec 8 W64) = 815-primOpTag (VecSubOp WordVec 16 W8) = 816-primOpTag (VecSubOp WordVec 8 W16) = 817-primOpTag (VecSubOp WordVec 4 W32) = 818-primOpTag (VecSubOp WordVec 2 W64) = 819-primOpTag (VecSubOp WordVec 32 W8) = 820-primOpTag (VecSubOp WordVec 16 W16) = 821-primOpTag (VecSubOp WordVec 8 W32) = 822-primOpTag (VecSubOp WordVec 4 W64) = 823-primOpTag (VecSubOp WordVec 64 W8) = 824-primOpTag (VecSubOp WordVec 32 W16) = 825-primOpTag (VecSubOp WordVec 16 W32) = 826-primOpTag (VecSubOp WordVec 8 W64) = 827-primOpTag (VecSubOp FloatVec 4 W32) = 828-primOpTag (VecSubOp FloatVec 2 W64) = 829-primOpTag (VecSubOp FloatVec 8 W32) = 830-primOpTag (VecSubOp FloatVec 4 W64) = 831-primOpTag (VecSubOp FloatVec 16 W32) = 832-primOpTag (VecSubOp FloatVec 8 W64) = 833-primOpTag (VecMulOp IntVec 16 W8) = 834-primOpTag (VecMulOp IntVec 8 W16) = 835-primOpTag (VecMulOp IntVec 4 W32) = 836-primOpTag (VecMulOp IntVec 2 W64) = 837-primOpTag (VecMulOp IntVec 32 W8) = 838-primOpTag (VecMulOp IntVec 16 W16) = 839-primOpTag (VecMulOp IntVec 8 W32) = 840-primOpTag (VecMulOp IntVec 4 W64) = 841-primOpTag (VecMulOp IntVec 64 W8) = 842-primOpTag (VecMulOp IntVec 32 W16) = 843-primOpTag (VecMulOp IntVec 16 W32) = 844-primOpTag (VecMulOp IntVec 8 W64) = 845-primOpTag (VecMulOp WordVec 16 W8) = 846-primOpTag (VecMulOp WordVec 8 W16) = 847-primOpTag (VecMulOp WordVec 4 W32) = 848-primOpTag (VecMulOp WordVec 2 W64) = 849-primOpTag (VecMulOp WordVec 32 W8) = 850-primOpTag (VecMulOp WordVec 16 W16) = 851-primOpTag (VecMulOp WordVec 8 W32) = 852-primOpTag (VecMulOp WordVec 4 W64) = 853-primOpTag (VecMulOp WordVec 64 W8) = 854-primOpTag (VecMulOp WordVec 32 W16) = 855-primOpTag (VecMulOp WordVec 16 W32) = 856-primOpTag (VecMulOp WordVec 8 W64) = 857-primOpTag (VecMulOp FloatVec 4 W32) = 858-primOpTag (VecMulOp FloatVec 2 W64) = 859-primOpTag (VecMulOp FloatVec 8 W32) = 860-primOpTag (VecMulOp FloatVec 4 W64) = 861-primOpTag (VecMulOp FloatVec 16 W32) = 862-primOpTag (VecMulOp FloatVec 8 W64) = 863-primOpTag (VecDivOp FloatVec 4 W32) = 864-primOpTag (VecDivOp FloatVec 2 W64) = 865-primOpTag (VecDivOp FloatVec 8 W32) = 866-primOpTag (VecDivOp FloatVec 4 W64) = 867-primOpTag (VecDivOp FloatVec 16 W32) = 868-primOpTag (VecDivOp FloatVec 8 W64) = 869-primOpTag (VecQuotOp IntVec 16 W8) = 870-primOpTag (VecQuotOp IntVec 8 W16) = 871-primOpTag (VecQuotOp IntVec 4 W32) = 872-primOpTag (VecQuotOp IntVec 2 W64) = 873-primOpTag (VecQuotOp IntVec 32 W8) = 874-primOpTag (VecQuotOp IntVec 16 W16) = 875-primOpTag (VecQuotOp IntVec 8 W32) = 876-primOpTag (VecQuotOp IntVec 4 W64) = 877-primOpTag (VecQuotOp IntVec 64 W8) = 878-primOpTag (VecQuotOp IntVec 32 W16) = 879-primOpTag (VecQuotOp IntVec 16 W32) = 880-primOpTag (VecQuotOp IntVec 8 W64) = 881-primOpTag (VecQuotOp WordVec 16 W8) = 882-primOpTag (VecQuotOp WordVec 8 W16) = 883-primOpTag (VecQuotOp WordVec 4 W32) = 884-primOpTag (VecQuotOp WordVec 2 W64) = 885-primOpTag (VecQuotOp WordVec 32 W8) = 886-primOpTag (VecQuotOp WordVec 16 W16) = 887-primOpTag (VecQuotOp WordVec 8 W32) = 888-primOpTag (VecQuotOp WordVec 4 W64) = 889-primOpTag (VecQuotOp WordVec 64 W8) = 890-primOpTag (VecQuotOp WordVec 32 W16) = 891-primOpTag (VecQuotOp WordVec 16 W32) = 892-primOpTag (VecQuotOp WordVec 8 W64) = 893-primOpTag (VecRemOp IntVec 16 W8) = 894-primOpTag (VecRemOp IntVec 8 W16) = 895-primOpTag (VecRemOp IntVec 4 W32) = 896-primOpTag (VecRemOp IntVec 2 W64) = 897-primOpTag (VecRemOp IntVec 32 W8) = 898-primOpTag (VecRemOp IntVec 16 W16) = 899-primOpTag (VecRemOp IntVec 8 W32) = 900-primOpTag (VecRemOp IntVec 4 W64) = 901-primOpTag (VecRemOp IntVec 64 W8) = 902-primOpTag (VecRemOp IntVec 32 W16) = 903-primOpTag (VecRemOp IntVec 16 W32) = 904-primOpTag (VecRemOp IntVec 8 W64) = 905-primOpTag (VecRemOp WordVec 16 W8) = 906-primOpTag (VecRemOp WordVec 8 W16) = 907-primOpTag (VecRemOp WordVec 4 W32) = 908-primOpTag (VecRemOp WordVec 2 W64) = 909-primOpTag (VecRemOp WordVec 32 W8) = 910-primOpTag (VecRemOp WordVec 16 W16) = 911-primOpTag (VecRemOp WordVec 8 W32) = 912-primOpTag (VecRemOp WordVec 4 W64) = 913-primOpTag (VecRemOp WordVec 64 W8) = 914-primOpTag (VecRemOp WordVec 32 W16) = 915-primOpTag (VecRemOp WordVec 16 W32) = 916-primOpTag (VecRemOp WordVec 8 W64) = 917-primOpTag (VecNegOp IntVec 16 W8) = 918-primOpTag (VecNegOp IntVec 8 W16) = 919-primOpTag (VecNegOp IntVec 4 W32) = 920-primOpTag (VecNegOp IntVec 2 W64) = 921-primOpTag (VecNegOp IntVec 32 W8) = 922-primOpTag (VecNegOp IntVec 16 W16) = 923-primOpTag (VecNegOp IntVec 8 W32) = 924-primOpTag (VecNegOp IntVec 4 W64) = 925-primOpTag (VecNegOp IntVec 64 W8) = 926-primOpTag (VecNegOp IntVec 32 W16) = 927-primOpTag (VecNegOp IntVec 16 W32) = 928-primOpTag (VecNegOp IntVec 8 W64) = 929-primOpTag (VecNegOp FloatVec 4 W32) = 930-primOpTag (VecNegOp FloatVec 2 W64) = 931-primOpTag (VecNegOp FloatVec 8 W32) = 932-primOpTag (VecNegOp FloatVec 4 W64) = 933-primOpTag (VecNegOp FloatVec 16 W32) = 934-primOpTag (VecNegOp FloatVec 8 W64) = 935-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 936-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 937-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 938-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 939-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 940-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 941-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 942-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 943-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 944-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 945-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 946-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 947-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 948-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 949-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 950-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 951-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 952-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 953-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 954-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 955-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 956-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 957-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 958-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 959-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 960-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 961-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 962-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 963-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 964-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 965-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 966-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 967-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 968-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 969-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 970-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 971-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 972-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 973-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 974-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 975-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 976-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 977-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 978-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 979-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 980-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 981-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 982-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 983-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 984-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 985-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 986-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 987-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 988-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 989-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 990-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 991-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 992-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 993-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 994-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 995-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 996-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 997-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 998-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 999-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1000-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1001-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1002-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1003-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1004-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1005-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1006-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1007-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1008-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1009-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1010-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1011-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1012-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1013-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1014-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1015-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1016-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1017-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1018-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1019-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1020-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1021-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1022-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1023-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1024-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1025-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1026-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1027-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1028-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1029-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1030-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1031-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1032-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1033-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1034-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1035-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1036-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1037-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1038-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1039-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1040-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1041-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1042-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1043-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1044-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1045-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1046-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1047-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1048-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1049-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1050-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1051-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1052-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1053-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1054-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1055-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1056-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1057-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1058-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1059-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1060-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1061-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1062-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1063-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1064-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1065-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1066-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1067-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1068-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1069-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1070-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1071-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1072-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1073-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1074-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1075-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1076-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1077-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1078-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1079-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1080-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1081-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1082-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1083-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1084-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1085-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1086-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1087-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1088-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1089-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1090-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1091-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1092-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1093-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1094-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1095-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1096-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1097-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1098-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1099-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1100-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1101-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1102-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1103-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1104-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1105-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1106-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1107-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1108-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1109-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1110-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1111-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1112-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1113-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1114-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1115-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1116-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1117-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1118-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1119-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1120-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1121-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1122-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1123-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1124-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1125-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1126-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1127-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1128-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1129-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1130-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1131-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1132-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1133-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1134-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1135-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1136-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1137-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1138-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1139-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1140-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1141-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1142-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1143-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1144-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1145-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1146-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1147-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1148-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1149-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1150-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1151-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1152-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1153-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1154-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1155-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1156-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1157-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1158-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1159-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1160-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1161-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1162-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1163-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1164-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1165-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1166-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1167-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1168-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1169-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1170-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1171-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1172-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1173-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1174-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1175-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1176-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1177-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1178-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1179-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1180-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1181-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1182-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1183-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1184-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1185-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1186-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1187-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1188-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1189-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1190-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1191-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1192-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1193-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1194-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1195-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1196-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1197-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1198-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1199-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1200-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1201-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1202-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1203-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1204-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1205-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1206-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1207-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1208-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1209-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1210-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1211-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1212-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1213-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1214-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1215-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1216-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1217-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1218-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1219-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1220-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1221-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1222-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1223-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1224-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1225-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1226-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1227-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1228-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1229-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1230-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1231-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1232-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1233-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1234-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1235-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1236-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1237-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1238-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1239-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1240-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1241-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1242-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1243-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1244-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1245-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1246-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1247-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1248-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1249-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1250-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1251-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1252-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1253-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1254-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1255-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1256-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1257-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1258-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1259-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1260-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1261-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1262-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1263-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1264-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1265-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1266-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1267-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1268-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1269-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1270-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1271-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1272-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1273-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1274-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1275-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1276-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1277-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1278-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1279-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1280-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1281-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1282-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1283-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1284-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1285-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1286-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1287-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1288-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1289-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1290-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1291-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1292-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1293-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1294-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1295-primOpTag PrefetchByteArrayOp3 = 1296-primOpTag PrefetchMutableByteArrayOp3 = 1297-primOpTag PrefetchAddrOp3 = 1298-primOpTag PrefetchValueOp3 = 1299-primOpTag PrefetchByteArrayOp2 = 1300-primOpTag PrefetchMutableByteArrayOp2 = 1301-primOpTag PrefetchAddrOp2 = 1302-primOpTag PrefetchValueOp2 = 1303-primOpTag PrefetchByteArrayOp1 = 1304-primOpTag PrefetchMutableByteArrayOp1 = 1305-primOpTag PrefetchAddrOp1 = 1306-primOpTag PrefetchValueOp1 = 1307-primOpTag PrefetchByteArrayOp0 = 1308-primOpTag PrefetchMutableByteArrayOp0 = 1309-primOpTag PrefetchAddrOp0 = 1310-primOpTag PrefetchValueOp0 = 1311+maxPrimOpTag = 1324+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 0+primOpTag CharGeOp = 1+primOpTag CharEqOp = 2+primOpTag CharNeOp = 3+primOpTag CharLtOp = 4+primOpTag CharLeOp = 5+primOpTag OrdOp = 6+primOpTag Int8ToIntOp = 7+primOpTag IntToInt8Op = 8+primOpTag Int8NegOp = 9+primOpTag Int8AddOp = 10+primOpTag Int8SubOp = 11+primOpTag Int8MulOp = 12+primOpTag Int8QuotOp = 13+primOpTag Int8RemOp = 14+primOpTag Int8QuotRemOp = 15+primOpTag Int8SllOp = 16+primOpTag Int8SraOp = 17+primOpTag Int8SrlOp = 18+primOpTag Int8ToWord8Op = 19+primOpTag Int8EqOp = 20+primOpTag Int8GeOp = 21+primOpTag Int8GtOp = 22+primOpTag Int8LeOp = 23+primOpTag Int8LtOp = 24+primOpTag Int8NeOp = 25+primOpTag Word8ToWordOp = 26+primOpTag WordToWord8Op = 27+primOpTag Word8AddOp = 28+primOpTag Word8SubOp = 29+primOpTag Word8MulOp = 30+primOpTag Word8QuotOp = 31+primOpTag Word8RemOp = 32+primOpTag Word8QuotRemOp = 33+primOpTag Word8AndOp = 34+primOpTag Word8OrOp = 35+primOpTag Word8XorOp = 36+primOpTag Word8NotOp = 37+primOpTag Word8SllOp = 38+primOpTag Word8SrlOp = 39+primOpTag Word8ToInt8Op = 40+primOpTag Word8EqOp = 41+primOpTag Word8GeOp = 42+primOpTag Word8GtOp = 43+primOpTag Word8LeOp = 44+primOpTag Word8LtOp = 45+primOpTag Word8NeOp = 46+primOpTag Int16ToIntOp = 47+primOpTag IntToInt16Op = 48+primOpTag Int16NegOp = 49+primOpTag Int16AddOp = 50+primOpTag Int16SubOp = 51+primOpTag Int16MulOp = 52+primOpTag Int16QuotOp = 53+primOpTag Int16RemOp = 54+primOpTag Int16QuotRemOp = 55+primOpTag Int16SllOp = 56+primOpTag Int16SraOp = 57+primOpTag Int16SrlOp = 58+primOpTag Int16ToWord16Op = 59+primOpTag Int16EqOp = 60+primOpTag Int16GeOp = 61+primOpTag Int16GtOp = 62+primOpTag Int16LeOp = 63+primOpTag Int16LtOp = 64+primOpTag Int16NeOp = 65+primOpTag Word16ToWordOp = 66+primOpTag WordToWord16Op = 67+primOpTag Word16AddOp = 68+primOpTag Word16SubOp = 69+primOpTag Word16MulOp = 70+primOpTag Word16QuotOp = 71+primOpTag Word16RemOp = 72+primOpTag Word16QuotRemOp = 73+primOpTag Word16AndOp = 74+primOpTag Word16OrOp = 75+primOpTag Word16XorOp = 76+primOpTag Word16NotOp = 77+primOpTag Word16SllOp = 78+primOpTag Word16SrlOp = 79+primOpTag Word16ToInt16Op = 80+primOpTag Word16EqOp = 81+primOpTag Word16GeOp = 82+primOpTag Word16GtOp = 83+primOpTag Word16LeOp = 84+primOpTag Word16LtOp = 85+primOpTag Word16NeOp = 86+primOpTag Int32ToIntOp = 87+primOpTag IntToInt32Op = 88+primOpTag Int32NegOp = 89+primOpTag Int32AddOp = 90+primOpTag Int32SubOp = 91+primOpTag Int32MulOp = 92+primOpTag Int32QuotOp = 93+primOpTag Int32RemOp = 94+primOpTag Int32QuotRemOp = 95+primOpTag Int32SllOp = 96+primOpTag Int32SraOp = 97+primOpTag Int32SrlOp = 98+primOpTag Int32ToWord32Op = 99+primOpTag Int32EqOp = 100+primOpTag Int32GeOp = 101+primOpTag Int32GtOp = 102+primOpTag Int32LeOp = 103+primOpTag Int32LtOp = 104+primOpTag Int32NeOp = 105+primOpTag Word32ToWordOp = 106+primOpTag WordToWord32Op = 107+primOpTag Word32AddOp = 108+primOpTag Word32SubOp = 109+primOpTag Word32MulOp = 110+primOpTag Word32QuotOp = 111+primOpTag Word32RemOp = 112+primOpTag Word32QuotRemOp = 113+primOpTag Word32AndOp = 114+primOpTag Word32OrOp = 115+primOpTag Word32XorOp = 116+primOpTag Word32NotOp = 117+primOpTag Word32SllOp = 118+primOpTag Word32SrlOp = 119+primOpTag Word32ToInt32Op = 120+primOpTag Word32EqOp = 121+primOpTag Word32GeOp = 122+primOpTag Word32GtOp = 123+primOpTag Word32LeOp = 124+primOpTag Word32LtOp = 125+primOpTag Word32NeOp = 126+primOpTag Int64ToIntOp = 127+primOpTag IntToInt64Op = 128+primOpTag Int64NegOp = 129+primOpTag Int64AddOp = 130+primOpTag Int64SubOp = 131+primOpTag Int64MulOp = 132+primOpTag Int64QuotOp = 133+primOpTag Int64RemOp = 134+primOpTag Int64SllOp = 135+primOpTag Int64SraOp = 136+primOpTag Int64SrlOp = 137+primOpTag Int64ToWord64Op = 138+primOpTag Int64EqOp = 139+primOpTag Int64GeOp = 140+primOpTag Int64GtOp = 141+primOpTag Int64LeOp = 142+primOpTag Int64LtOp = 143+primOpTag Int64NeOp = 144+primOpTag Word64ToWordOp = 145+primOpTag WordToWord64Op = 146+primOpTag Word64AddOp = 147+primOpTag Word64SubOp = 148+primOpTag Word64MulOp = 149+primOpTag Word64QuotOp = 150+primOpTag Word64RemOp = 151+primOpTag Word64AndOp = 152+primOpTag Word64OrOp = 153+primOpTag Word64XorOp = 154+primOpTag Word64NotOp = 155+primOpTag Word64SllOp = 156+primOpTag Word64SrlOp = 157+primOpTag Word64ToInt64Op = 158+primOpTag Word64EqOp = 159+primOpTag Word64GeOp = 160+primOpTag Word64GtOp = 161+primOpTag Word64LeOp = 162+primOpTag Word64LtOp = 163+primOpTag Word64NeOp = 164+primOpTag IntAddOp = 165+primOpTag IntSubOp = 166+primOpTag IntMulOp = 167+primOpTag IntMul2Op = 168+primOpTag IntMulMayOfloOp = 169+primOpTag IntQuotOp = 170+primOpTag IntRemOp = 171+primOpTag IntQuotRemOp = 172+primOpTag IntAndOp = 173+primOpTag IntOrOp = 174+primOpTag IntXorOp = 175+primOpTag IntNotOp = 176+primOpTag IntNegOp = 177+primOpTag IntAddCOp = 178+primOpTag IntSubCOp = 179+primOpTag IntGtOp = 180+primOpTag IntGeOp = 181+primOpTag IntEqOp = 182+primOpTag IntNeOp = 183+primOpTag IntLtOp = 184+primOpTag IntLeOp = 185+primOpTag ChrOp = 186+primOpTag IntToWordOp = 187+primOpTag IntToFloatOp = 188+primOpTag IntToDoubleOp = 189+primOpTag WordToFloatOp = 190+primOpTag WordToDoubleOp = 191+primOpTag IntSllOp = 192+primOpTag IntSraOp = 193+primOpTag IntSrlOp = 194+primOpTag WordAddOp = 195+primOpTag WordAddCOp = 196+primOpTag WordSubCOp = 197+primOpTag WordAdd2Op = 198+primOpTag WordSubOp = 199+primOpTag WordMulOp = 200+primOpTag WordMul2Op = 201+primOpTag WordQuotOp = 202+primOpTag WordRemOp = 203+primOpTag WordQuotRemOp = 204+primOpTag WordQuotRem2Op = 205+primOpTag WordAndOp = 206+primOpTag WordOrOp = 207+primOpTag WordXorOp = 208+primOpTag WordNotOp = 209+primOpTag WordSllOp = 210+primOpTag WordSrlOp = 211+primOpTag WordToIntOp = 212+primOpTag WordGtOp = 213+primOpTag WordGeOp = 214+primOpTag WordEqOp = 215+primOpTag WordNeOp = 216+primOpTag WordLtOp = 217+primOpTag WordLeOp = 218+primOpTag PopCnt8Op = 219+primOpTag PopCnt16Op = 220+primOpTag PopCnt32Op = 221+primOpTag PopCnt64Op = 222+primOpTag PopCntOp = 223+primOpTag Pdep8Op = 224+primOpTag Pdep16Op = 225+primOpTag Pdep32Op = 226+primOpTag Pdep64Op = 227+primOpTag PdepOp = 228+primOpTag Pext8Op = 229+primOpTag Pext16Op = 230+primOpTag Pext32Op = 231+primOpTag Pext64Op = 232+primOpTag PextOp = 233+primOpTag Clz8Op = 234+primOpTag Clz16Op = 235+primOpTag Clz32Op = 236+primOpTag Clz64Op = 237+primOpTag ClzOp = 238+primOpTag Ctz8Op = 239+primOpTag Ctz16Op = 240+primOpTag Ctz32Op = 241+primOpTag Ctz64Op = 242+primOpTag CtzOp = 243+primOpTag BSwap16Op = 244+primOpTag BSwap32Op = 245+primOpTag BSwap64Op = 246+primOpTag BSwapOp = 247+primOpTag BRev8Op = 248+primOpTag BRev16Op = 249+primOpTag BRev32Op = 250+primOpTag BRev64Op = 251+primOpTag BRevOp = 252+primOpTag Narrow8IntOp = 253+primOpTag Narrow16IntOp = 254+primOpTag Narrow32IntOp = 255+primOpTag Narrow8WordOp = 256+primOpTag Narrow16WordOp = 257+primOpTag Narrow32WordOp = 258+primOpTag DoubleGtOp = 259+primOpTag DoubleGeOp = 260+primOpTag DoubleEqOp = 261+primOpTag DoubleNeOp = 262+primOpTag DoubleLtOp = 263+primOpTag DoubleLeOp = 264+primOpTag DoubleAddOp = 265+primOpTag DoubleSubOp = 266+primOpTag DoubleMulOp = 267+primOpTag DoubleDivOp = 268+primOpTag DoubleNegOp = 269+primOpTag DoubleFabsOp = 270+primOpTag DoubleToIntOp = 271+primOpTag DoubleToFloatOp = 272+primOpTag DoubleExpOp = 273+primOpTag DoubleExpM1Op = 274+primOpTag DoubleLogOp = 275+primOpTag DoubleLog1POp = 276+primOpTag DoubleSqrtOp = 277+primOpTag DoubleSinOp = 278+primOpTag DoubleCosOp = 279+primOpTag DoubleTanOp = 280+primOpTag DoubleAsinOp = 281+primOpTag DoubleAcosOp = 282+primOpTag DoubleAtanOp = 283+primOpTag DoubleSinhOp = 284+primOpTag DoubleCoshOp = 285+primOpTag DoubleTanhOp = 286+primOpTag DoubleAsinhOp = 287+primOpTag DoubleAcoshOp = 288+primOpTag DoubleAtanhOp = 289+primOpTag DoublePowerOp = 290+primOpTag DoubleDecode_2IntOp = 291+primOpTag DoubleDecode_Int64Op = 292+primOpTag FloatGtOp = 293+primOpTag FloatGeOp = 294+primOpTag FloatEqOp = 295+primOpTag FloatNeOp = 296+primOpTag FloatLtOp = 297+primOpTag FloatLeOp = 298+primOpTag FloatAddOp = 299+primOpTag FloatSubOp = 300+primOpTag FloatMulOp = 301+primOpTag FloatDivOp = 302+primOpTag FloatNegOp = 303+primOpTag FloatFabsOp = 304+primOpTag FloatToIntOp = 305+primOpTag FloatExpOp = 306+primOpTag FloatExpM1Op = 307+primOpTag FloatLogOp = 308+primOpTag FloatLog1POp = 309+primOpTag FloatSqrtOp = 310+primOpTag FloatSinOp = 311+primOpTag FloatCosOp = 312+primOpTag FloatTanOp = 313+primOpTag FloatAsinOp = 314+primOpTag FloatAcosOp = 315+primOpTag FloatAtanOp = 316+primOpTag FloatSinhOp = 317+primOpTag FloatCoshOp = 318+primOpTag FloatTanhOp = 319+primOpTag FloatAsinhOp = 320+primOpTag FloatAcoshOp = 321+primOpTag FloatAtanhOp = 322+primOpTag FloatPowerOp = 323+primOpTag FloatToDoubleOp = 324+primOpTag FloatDecode_IntOp = 325+primOpTag FloatFMAdd = 326+primOpTag FloatFMSub = 327+primOpTag FloatFNMAdd = 328+primOpTag FloatFNMSub = 329+primOpTag DoubleFMAdd = 330+primOpTag DoubleFMSub = 331+primOpTag DoubleFNMAdd = 332+primOpTag DoubleFNMSub = 333+primOpTag NewArrayOp = 334+primOpTag ReadArrayOp = 335+primOpTag WriteArrayOp = 336+primOpTag SizeofArrayOp = 337+primOpTag SizeofMutableArrayOp = 338+primOpTag IndexArrayOp = 339+primOpTag UnsafeFreezeArrayOp = 340+primOpTag UnsafeThawArrayOp = 341+primOpTag CopyArrayOp = 342+primOpTag CopyMutableArrayOp = 343+primOpTag CloneArrayOp = 344+primOpTag CloneMutableArrayOp = 345+primOpTag FreezeArrayOp = 346+primOpTag ThawArrayOp = 347+primOpTag CasArrayOp = 348+primOpTag NewSmallArrayOp = 349+primOpTag ShrinkSmallMutableArrayOp_Char = 350+primOpTag ReadSmallArrayOp = 351+primOpTag WriteSmallArrayOp = 352+primOpTag SizeofSmallArrayOp = 353+primOpTag SizeofSmallMutableArrayOp = 354+primOpTag GetSizeofSmallMutableArrayOp = 355+primOpTag IndexSmallArrayOp = 356+primOpTag UnsafeFreezeSmallArrayOp = 357+primOpTag UnsafeThawSmallArrayOp = 358+primOpTag CopySmallArrayOp = 359+primOpTag CopySmallMutableArrayOp = 360+primOpTag CloneSmallArrayOp = 361+primOpTag CloneSmallMutableArrayOp = 362+primOpTag FreezeSmallArrayOp = 363+primOpTag ThawSmallArrayOp = 364+primOpTag CasSmallArrayOp = 365+primOpTag NewByteArrayOp_Char = 366+primOpTag NewPinnedByteArrayOp_Char = 367+primOpTag NewAlignedPinnedByteArrayOp_Char = 368+primOpTag MutableByteArrayIsPinnedOp = 369+primOpTag ByteArrayIsPinnedOp = 370+primOpTag ByteArrayContents_Char = 371+primOpTag MutableByteArrayContents_Char = 372+primOpTag ShrinkMutableByteArrayOp_Char = 373+primOpTag ResizeMutableByteArrayOp_Char = 374+primOpTag UnsafeFreezeByteArrayOp = 375+primOpTag SizeofByteArrayOp = 376+primOpTag SizeofMutableByteArrayOp = 377+primOpTag GetSizeofMutableByteArrayOp = 378+primOpTag IndexByteArrayOp_Char = 379+primOpTag IndexByteArrayOp_WideChar = 380+primOpTag IndexByteArrayOp_Int = 381+primOpTag IndexByteArrayOp_Word = 382+primOpTag IndexByteArrayOp_Addr = 383+primOpTag IndexByteArrayOp_Float = 384+primOpTag IndexByteArrayOp_Double = 385+primOpTag IndexByteArrayOp_StablePtr = 386+primOpTag IndexByteArrayOp_Int8 = 387+primOpTag IndexByteArrayOp_Word8 = 388+primOpTag IndexByteArrayOp_Int16 = 389+primOpTag IndexByteArrayOp_Word16 = 390+primOpTag IndexByteArrayOp_Int32 = 391+primOpTag IndexByteArrayOp_Word32 = 392+primOpTag IndexByteArrayOp_Int64 = 393+primOpTag IndexByteArrayOp_Word64 = 394+primOpTag IndexByteArrayOp_Word8AsChar = 395+primOpTag IndexByteArrayOp_Word8AsWideChar = 396+primOpTag IndexByteArrayOp_Word8AsInt = 397+primOpTag IndexByteArrayOp_Word8AsWord = 398+primOpTag IndexByteArrayOp_Word8AsAddr = 399+primOpTag IndexByteArrayOp_Word8AsFloat = 400+primOpTag IndexByteArrayOp_Word8AsDouble = 401+primOpTag IndexByteArrayOp_Word8AsStablePtr = 402+primOpTag IndexByteArrayOp_Word8AsInt16 = 403+primOpTag IndexByteArrayOp_Word8AsWord16 = 404+primOpTag IndexByteArrayOp_Word8AsInt32 = 405+primOpTag IndexByteArrayOp_Word8AsWord32 = 406+primOpTag IndexByteArrayOp_Word8AsInt64 = 407+primOpTag IndexByteArrayOp_Word8AsWord64 = 408+primOpTag ReadByteArrayOp_Char = 409+primOpTag ReadByteArrayOp_WideChar = 410+primOpTag ReadByteArrayOp_Int = 411+primOpTag ReadByteArrayOp_Word = 412+primOpTag ReadByteArrayOp_Addr = 413+primOpTag ReadByteArrayOp_Float = 414+primOpTag ReadByteArrayOp_Double = 415+primOpTag ReadByteArrayOp_StablePtr = 416+primOpTag ReadByteArrayOp_Int8 = 417+primOpTag ReadByteArrayOp_Word8 = 418+primOpTag ReadByteArrayOp_Int16 = 419+primOpTag ReadByteArrayOp_Word16 = 420+primOpTag ReadByteArrayOp_Int32 = 421+primOpTag ReadByteArrayOp_Word32 = 422+primOpTag ReadByteArrayOp_Int64 = 423+primOpTag ReadByteArrayOp_Word64 = 424+primOpTag ReadByteArrayOp_Word8AsChar = 425+primOpTag ReadByteArrayOp_Word8AsWideChar = 426+primOpTag ReadByteArrayOp_Word8AsInt = 427+primOpTag ReadByteArrayOp_Word8AsWord = 428+primOpTag ReadByteArrayOp_Word8AsAddr = 429+primOpTag ReadByteArrayOp_Word8AsFloat = 430+primOpTag ReadByteArrayOp_Word8AsDouble = 431+primOpTag ReadByteArrayOp_Word8AsStablePtr = 432+primOpTag ReadByteArrayOp_Word8AsInt16 = 433+primOpTag ReadByteArrayOp_Word8AsWord16 = 434+primOpTag ReadByteArrayOp_Word8AsInt32 = 435+primOpTag ReadByteArrayOp_Word8AsWord32 = 436+primOpTag ReadByteArrayOp_Word8AsInt64 = 437+primOpTag ReadByteArrayOp_Word8AsWord64 = 438+primOpTag WriteByteArrayOp_Char = 439+primOpTag WriteByteArrayOp_WideChar = 440+primOpTag WriteByteArrayOp_Int = 441+primOpTag WriteByteArrayOp_Word = 442+primOpTag WriteByteArrayOp_Addr = 443+primOpTag WriteByteArrayOp_Float = 444+primOpTag WriteByteArrayOp_Double = 445+primOpTag WriteByteArrayOp_StablePtr = 446+primOpTag WriteByteArrayOp_Int8 = 447+primOpTag WriteByteArrayOp_Word8 = 448+primOpTag WriteByteArrayOp_Int16 = 449+primOpTag WriteByteArrayOp_Word16 = 450+primOpTag WriteByteArrayOp_Int32 = 451+primOpTag WriteByteArrayOp_Word32 = 452+primOpTag WriteByteArrayOp_Int64 = 453+primOpTag WriteByteArrayOp_Word64 = 454+primOpTag WriteByteArrayOp_Word8AsChar = 455+primOpTag WriteByteArrayOp_Word8AsWideChar = 456+primOpTag WriteByteArrayOp_Word8AsInt = 457+primOpTag WriteByteArrayOp_Word8AsWord = 458+primOpTag WriteByteArrayOp_Word8AsAddr = 459+primOpTag WriteByteArrayOp_Word8AsFloat = 460+primOpTag WriteByteArrayOp_Word8AsDouble = 461+primOpTag WriteByteArrayOp_Word8AsStablePtr = 462+primOpTag WriteByteArrayOp_Word8AsInt16 = 463+primOpTag WriteByteArrayOp_Word8AsWord16 = 464+primOpTag WriteByteArrayOp_Word8AsInt32 = 465+primOpTag WriteByteArrayOp_Word8AsWord32 = 466+primOpTag WriteByteArrayOp_Word8AsInt64 = 467+primOpTag WriteByteArrayOp_Word8AsWord64 = 468+primOpTag CompareByteArraysOp = 469+primOpTag CopyByteArrayOp = 470+primOpTag CopyMutableByteArrayOp = 471+primOpTag CopyMutableByteArrayNonOverlappingOp = 472+primOpTag CopyByteArrayToAddrOp = 473+primOpTag CopyMutableByteArrayToAddrOp = 474+primOpTag CopyAddrToByteArrayOp = 475+primOpTag CopyAddrToAddrOp = 476+primOpTag CopyAddrToAddrNonOverlappingOp = 477+primOpTag SetByteArrayOp = 478+primOpTag SetAddrRangeOp = 479+primOpTag AtomicReadByteArrayOp_Int = 480+primOpTag AtomicWriteByteArrayOp_Int = 481+primOpTag CasByteArrayOp_Int = 482+primOpTag CasByteArrayOp_Int8 = 483+primOpTag CasByteArrayOp_Int16 = 484+primOpTag CasByteArrayOp_Int32 = 485+primOpTag CasByteArrayOp_Int64 = 486+primOpTag FetchAddByteArrayOp_Int = 487+primOpTag FetchSubByteArrayOp_Int = 488+primOpTag FetchAndByteArrayOp_Int = 489+primOpTag FetchNandByteArrayOp_Int = 490+primOpTag FetchOrByteArrayOp_Int = 491+primOpTag FetchXorByteArrayOp_Int = 492+primOpTag AddrAddOp = 493+primOpTag AddrSubOp = 494+primOpTag AddrRemOp = 495+primOpTag AddrToIntOp = 496+primOpTag IntToAddrOp = 497+primOpTag AddrGtOp = 498+primOpTag AddrGeOp = 499+primOpTag AddrEqOp = 500+primOpTag AddrNeOp = 501+primOpTag AddrLtOp = 502+primOpTag AddrLeOp = 503+primOpTag IndexOffAddrOp_Char = 504+primOpTag IndexOffAddrOp_WideChar = 505+primOpTag IndexOffAddrOp_Int = 506+primOpTag IndexOffAddrOp_Word = 507+primOpTag IndexOffAddrOp_Addr = 508+primOpTag IndexOffAddrOp_Float = 509+primOpTag IndexOffAddrOp_Double = 510+primOpTag IndexOffAddrOp_StablePtr = 511+primOpTag IndexOffAddrOp_Int8 = 512+primOpTag IndexOffAddrOp_Word8 = 513+primOpTag IndexOffAddrOp_Int16 = 514+primOpTag IndexOffAddrOp_Word16 = 515+primOpTag IndexOffAddrOp_Int32 = 516+primOpTag IndexOffAddrOp_Word32 = 517+primOpTag IndexOffAddrOp_Int64 = 518+primOpTag IndexOffAddrOp_Word64 = 519+primOpTag ReadOffAddrOp_Char = 520+primOpTag ReadOffAddrOp_WideChar = 521+primOpTag ReadOffAddrOp_Int = 522+primOpTag ReadOffAddrOp_Word = 523+primOpTag ReadOffAddrOp_Addr = 524+primOpTag ReadOffAddrOp_Float = 525+primOpTag ReadOffAddrOp_Double = 526+primOpTag ReadOffAddrOp_StablePtr = 527+primOpTag ReadOffAddrOp_Int8 = 528+primOpTag ReadOffAddrOp_Word8 = 529+primOpTag ReadOffAddrOp_Int16 = 530+primOpTag ReadOffAddrOp_Word16 = 531+primOpTag ReadOffAddrOp_Int32 = 532+primOpTag ReadOffAddrOp_Word32 = 533+primOpTag ReadOffAddrOp_Int64 = 534+primOpTag ReadOffAddrOp_Word64 = 535+primOpTag WriteOffAddrOp_Char = 536+primOpTag WriteOffAddrOp_WideChar = 537+primOpTag WriteOffAddrOp_Int = 538+primOpTag WriteOffAddrOp_Word = 539+primOpTag WriteOffAddrOp_Addr = 540+primOpTag WriteOffAddrOp_Float = 541+primOpTag WriteOffAddrOp_Double = 542+primOpTag WriteOffAddrOp_StablePtr = 543+primOpTag WriteOffAddrOp_Int8 = 544+primOpTag WriteOffAddrOp_Word8 = 545+primOpTag WriteOffAddrOp_Int16 = 546+primOpTag WriteOffAddrOp_Word16 = 547+primOpTag WriteOffAddrOp_Int32 = 548+primOpTag WriteOffAddrOp_Word32 = 549+primOpTag WriteOffAddrOp_Int64 = 550+primOpTag WriteOffAddrOp_Word64 = 551+primOpTag InterlockedExchange_Addr = 552+primOpTag InterlockedExchange_Word = 553+primOpTag CasAddrOp_Addr = 554+primOpTag CasAddrOp_Word = 555+primOpTag CasAddrOp_Word8 = 556+primOpTag CasAddrOp_Word16 = 557+primOpTag CasAddrOp_Word32 = 558+primOpTag CasAddrOp_Word64 = 559+primOpTag FetchAddAddrOp_Word = 560+primOpTag FetchSubAddrOp_Word = 561+primOpTag FetchAndAddrOp_Word = 562+primOpTag FetchNandAddrOp_Word = 563+primOpTag FetchOrAddrOp_Word = 564+primOpTag FetchXorAddrOp_Word = 565+primOpTag AtomicReadAddrOp_Word = 566+primOpTag AtomicWriteAddrOp_Word = 567+primOpTag NewMutVarOp = 568+primOpTag ReadMutVarOp = 569+primOpTag WriteMutVarOp = 570+primOpTag AtomicSwapMutVarOp = 571+primOpTag AtomicModifyMutVar2Op = 572+primOpTag AtomicModifyMutVar_Op = 573+primOpTag CasMutVarOp = 574+primOpTag CatchOp = 575+primOpTag RaiseOp = 576+primOpTag RaiseUnderflowOp = 577+primOpTag RaiseOverflowOp = 578+primOpTag RaiseDivZeroOp = 579+primOpTag RaiseIOOp = 580+primOpTag MaskAsyncExceptionsOp = 581+primOpTag MaskUninterruptibleOp = 582+primOpTag UnmaskAsyncExceptionsOp = 583+primOpTag MaskStatus = 584+primOpTag NewPromptTagOp = 585+primOpTag PromptOp = 586+primOpTag Control0Op = 587+primOpTag AtomicallyOp = 588+primOpTag RetryOp = 589+primOpTag CatchRetryOp = 590+primOpTag CatchSTMOp = 591+primOpTag NewTVarOp = 592+primOpTag ReadTVarOp = 593+primOpTag ReadTVarIOOp = 594+primOpTag WriteTVarOp = 595+primOpTag NewMVarOp = 596+primOpTag TakeMVarOp = 597+primOpTag TryTakeMVarOp = 598+primOpTag PutMVarOp = 599+primOpTag TryPutMVarOp = 600+primOpTag ReadMVarOp = 601+primOpTag TryReadMVarOp = 602+primOpTag IsEmptyMVarOp = 603+primOpTag NewIOPortOp = 604+primOpTag ReadIOPortOp = 605+primOpTag WriteIOPortOp = 606+primOpTag DelayOp = 607+primOpTag WaitReadOp = 608+primOpTag WaitWriteOp = 609+primOpTag ForkOp = 610+primOpTag ForkOnOp = 611+primOpTag KillThreadOp = 612+primOpTag YieldOp = 613+primOpTag MyThreadIdOp = 614+primOpTag LabelThreadOp = 615+primOpTag IsCurrentThreadBoundOp = 616+primOpTag NoDuplicateOp = 617+primOpTag GetThreadLabelOp = 618+primOpTag ThreadStatusOp = 619+primOpTag ListThreadsOp = 620+primOpTag MkWeakOp = 621+primOpTag MkWeakNoFinalizerOp = 622+primOpTag AddCFinalizerToWeakOp = 623+primOpTag DeRefWeakOp = 624+primOpTag FinalizeWeakOp = 625+primOpTag TouchOp = 626+primOpTag MakeStablePtrOp = 627+primOpTag DeRefStablePtrOp = 628+primOpTag EqStablePtrOp = 629+primOpTag MakeStableNameOp = 630+primOpTag StableNameToIntOp = 631+primOpTag CompactNewOp = 632+primOpTag CompactResizeOp = 633+primOpTag CompactContainsOp = 634+primOpTag CompactContainsAnyOp = 635+primOpTag CompactGetFirstBlockOp = 636+primOpTag CompactGetNextBlockOp = 637+primOpTag CompactAllocateBlockOp = 638+primOpTag CompactFixupPointersOp = 639+primOpTag CompactAdd = 640+primOpTag CompactAddWithSharing = 641+primOpTag CompactSize = 642+primOpTag ReallyUnsafePtrEqualityOp = 643+primOpTag ParOp = 644+primOpTag SparkOp = 645+primOpTag SeqOp = 646+primOpTag GetSparkOp = 647+primOpTag NumSparks = 648+primOpTag KeepAliveOp = 649+primOpTag DataToTagOp = 650+primOpTag TagToEnumOp = 651+primOpTag AddrToAnyOp = 652+primOpTag AnyToAddrOp = 653+primOpTag MkApUpd0_Op = 654+primOpTag NewBCOOp = 655+primOpTag UnpackClosureOp = 656+primOpTag ClosureSizeOp = 657+primOpTag GetApStackValOp = 658+primOpTag GetCCSOfOp = 659+primOpTag GetCurrentCCSOp = 660+primOpTag ClearCCSOp = 661+primOpTag WhereFromOp = 662+primOpTag TraceEventOp = 663+primOpTag TraceEventBinaryOp = 664+primOpTag TraceMarkerOp = 665+primOpTag SetThreadAllocationCounter = 666+primOpTag (VecBroadcastOp IntVec 16 W8) = 667+primOpTag (VecBroadcastOp IntVec 8 W16) = 668+primOpTag (VecBroadcastOp IntVec 4 W32) = 669+primOpTag (VecBroadcastOp IntVec 2 W64) = 670+primOpTag (VecBroadcastOp IntVec 32 W8) = 671+primOpTag (VecBroadcastOp IntVec 16 W16) = 672+primOpTag (VecBroadcastOp IntVec 8 W32) = 673+primOpTag (VecBroadcastOp IntVec 4 W64) = 674+primOpTag (VecBroadcastOp IntVec 64 W8) = 675+primOpTag (VecBroadcastOp IntVec 32 W16) = 676+primOpTag (VecBroadcastOp IntVec 16 W32) = 677+primOpTag (VecBroadcastOp IntVec 8 W64) = 678+primOpTag (VecBroadcastOp WordVec 16 W8) = 679+primOpTag (VecBroadcastOp WordVec 8 W16) = 680+primOpTag (VecBroadcastOp WordVec 4 W32) = 681+primOpTag (VecBroadcastOp WordVec 2 W64) = 682+primOpTag (VecBroadcastOp WordVec 32 W8) = 683+primOpTag (VecBroadcastOp WordVec 16 W16) = 684+primOpTag (VecBroadcastOp WordVec 8 W32) = 685+primOpTag (VecBroadcastOp WordVec 4 W64) = 686+primOpTag (VecBroadcastOp WordVec 64 W8) = 687+primOpTag (VecBroadcastOp WordVec 32 W16) = 688+primOpTag (VecBroadcastOp WordVec 16 W32) = 689+primOpTag (VecBroadcastOp WordVec 8 W64) = 690+primOpTag (VecBroadcastOp FloatVec 4 W32) = 691+primOpTag (VecBroadcastOp FloatVec 2 W64) = 692+primOpTag (VecBroadcastOp FloatVec 8 W32) = 693+primOpTag (VecBroadcastOp FloatVec 4 W64) = 694+primOpTag (VecBroadcastOp FloatVec 16 W32) = 695+primOpTag (VecBroadcastOp FloatVec 8 W64) = 696+primOpTag (VecPackOp IntVec 16 W8) = 697+primOpTag (VecPackOp IntVec 8 W16) = 698+primOpTag (VecPackOp IntVec 4 W32) = 699+primOpTag (VecPackOp IntVec 2 W64) = 700+primOpTag (VecPackOp IntVec 32 W8) = 701+primOpTag (VecPackOp IntVec 16 W16) = 702+primOpTag (VecPackOp IntVec 8 W32) = 703+primOpTag (VecPackOp IntVec 4 W64) = 704+primOpTag (VecPackOp IntVec 64 W8) = 705+primOpTag (VecPackOp IntVec 32 W16) = 706+primOpTag (VecPackOp IntVec 16 W32) = 707+primOpTag (VecPackOp IntVec 8 W64) = 708+primOpTag (VecPackOp WordVec 16 W8) = 709+primOpTag (VecPackOp WordVec 8 W16) = 710+primOpTag (VecPackOp WordVec 4 W32) = 711+primOpTag (VecPackOp WordVec 2 W64) = 712+primOpTag (VecPackOp WordVec 32 W8) = 713+primOpTag (VecPackOp WordVec 16 W16) = 714+primOpTag (VecPackOp WordVec 8 W32) = 715+primOpTag (VecPackOp WordVec 4 W64) = 716+primOpTag (VecPackOp WordVec 64 W8) = 717+primOpTag (VecPackOp WordVec 32 W16) = 718+primOpTag (VecPackOp WordVec 16 W32) = 719+primOpTag (VecPackOp WordVec 8 W64) = 720+primOpTag (VecPackOp FloatVec 4 W32) = 721+primOpTag (VecPackOp FloatVec 2 W64) = 722+primOpTag (VecPackOp FloatVec 8 W32) = 723+primOpTag (VecPackOp FloatVec 4 W64) = 724+primOpTag (VecPackOp FloatVec 16 W32) = 725+primOpTag (VecPackOp FloatVec 8 W64) = 726+primOpTag (VecUnpackOp IntVec 16 W8) = 727+primOpTag (VecUnpackOp IntVec 8 W16) = 728+primOpTag (VecUnpackOp IntVec 4 W32) = 729+primOpTag (VecUnpackOp IntVec 2 W64) = 730+primOpTag (VecUnpackOp IntVec 32 W8) = 731+primOpTag (VecUnpackOp IntVec 16 W16) = 732+primOpTag (VecUnpackOp IntVec 8 W32) = 733+primOpTag (VecUnpackOp IntVec 4 W64) = 734+primOpTag (VecUnpackOp IntVec 64 W8) = 735+primOpTag (VecUnpackOp IntVec 32 W16) = 736+primOpTag (VecUnpackOp IntVec 16 W32) = 737+primOpTag (VecUnpackOp IntVec 8 W64) = 738+primOpTag (VecUnpackOp WordVec 16 W8) = 739+primOpTag (VecUnpackOp WordVec 8 W16) = 740+primOpTag (VecUnpackOp WordVec 4 W32) = 741+primOpTag (VecUnpackOp WordVec 2 W64) = 742+primOpTag (VecUnpackOp WordVec 32 W8) = 743+primOpTag (VecUnpackOp WordVec 16 W16) = 744+primOpTag (VecUnpackOp WordVec 8 W32) = 745+primOpTag (VecUnpackOp WordVec 4 W64) = 746+primOpTag (VecUnpackOp WordVec 64 W8) = 747+primOpTag (VecUnpackOp WordVec 32 W16) = 748+primOpTag (VecUnpackOp WordVec 16 W32) = 749+primOpTag (VecUnpackOp WordVec 8 W64) = 750+primOpTag (VecUnpackOp FloatVec 4 W32) = 751+primOpTag (VecUnpackOp FloatVec 2 W64) = 752+primOpTag (VecUnpackOp FloatVec 8 W32) = 753+primOpTag (VecUnpackOp FloatVec 4 W64) = 754+primOpTag (VecUnpackOp FloatVec 16 W32) = 755+primOpTag (VecUnpackOp FloatVec 8 W64) = 756+primOpTag (VecInsertOp IntVec 16 W8) = 757+primOpTag (VecInsertOp IntVec 8 W16) = 758+primOpTag (VecInsertOp IntVec 4 W32) = 759+primOpTag (VecInsertOp IntVec 2 W64) = 760+primOpTag (VecInsertOp IntVec 32 W8) = 761+primOpTag (VecInsertOp IntVec 16 W16) = 762+primOpTag (VecInsertOp IntVec 8 W32) = 763+primOpTag (VecInsertOp IntVec 4 W64) = 764+primOpTag (VecInsertOp IntVec 64 W8) = 765+primOpTag (VecInsertOp IntVec 32 W16) = 766+primOpTag (VecInsertOp IntVec 16 W32) = 767+primOpTag (VecInsertOp IntVec 8 W64) = 768+primOpTag (VecInsertOp WordVec 16 W8) = 769+primOpTag (VecInsertOp WordVec 8 W16) = 770+primOpTag (VecInsertOp WordVec 4 W32) = 771+primOpTag (VecInsertOp WordVec 2 W64) = 772+primOpTag (VecInsertOp WordVec 32 W8) = 773+primOpTag (VecInsertOp WordVec 16 W16) = 774+primOpTag (VecInsertOp WordVec 8 W32) = 775+primOpTag (VecInsertOp WordVec 4 W64) = 776+primOpTag (VecInsertOp WordVec 64 W8) = 777+primOpTag (VecInsertOp WordVec 32 W16) = 778+primOpTag (VecInsertOp WordVec 16 W32) = 779+primOpTag (VecInsertOp WordVec 8 W64) = 780+primOpTag (VecInsertOp FloatVec 4 W32) = 781+primOpTag (VecInsertOp FloatVec 2 W64) = 782+primOpTag (VecInsertOp FloatVec 8 W32) = 783+primOpTag (VecInsertOp FloatVec 4 W64) = 784+primOpTag (VecInsertOp FloatVec 16 W32) = 785+primOpTag (VecInsertOp FloatVec 8 W64) = 786+primOpTag (VecAddOp IntVec 16 W8) = 787+primOpTag (VecAddOp IntVec 8 W16) = 788+primOpTag (VecAddOp IntVec 4 W32) = 789+primOpTag (VecAddOp IntVec 2 W64) = 790+primOpTag (VecAddOp IntVec 32 W8) = 791+primOpTag (VecAddOp IntVec 16 W16) = 792+primOpTag (VecAddOp IntVec 8 W32) = 793+primOpTag (VecAddOp IntVec 4 W64) = 794+primOpTag (VecAddOp IntVec 64 W8) = 795+primOpTag (VecAddOp IntVec 32 W16) = 796+primOpTag (VecAddOp IntVec 16 W32) = 797+primOpTag (VecAddOp IntVec 8 W64) = 798+primOpTag (VecAddOp WordVec 16 W8) = 799+primOpTag (VecAddOp WordVec 8 W16) = 800+primOpTag (VecAddOp WordVec 4 W32) = 801+primOpTag (VecAddOp WordVec 2 W64) = 802+primOpTag (VecAddOp WordVec 32 W8) = 803+primOpTag (VecAddOp WordVec 16 W16) = 804+primOpTag (VecAddOp WordVec 8 W32) = 805+primOpTag (VecAddOp WordVec 4 W64) = 806+primOpTag (VecAddOp WordVec 64 W8) = 807+primOpTag (VecAddOp WordVec 32 W16) = 808+primOpTag (VecAddOp WordVec 16 W32) = 809+primOpTag (VecAddOp WordVec 8 W64) = 810+primOpTag (VecAddOp FloatVec 4 W32) = 811+primOpTag (VecAddOp FloatVec 2 W64) = 812+primOpTag (VecAddOp FloatVec 8 W32) = 813+primOpTag (VecAddOp FloatVec 4 W64) = 814+primOpTag (VecAddOp FloatVec 16 W32) = 815+primOpTag (VecAddOp FloatVec 8 W64) = 816+primOpTag (VecSubOp IntVec 16 W8) = 817+primOpTag (VecSubOp IntVec 8 W16) = 818+primOpTag (VecSubOp IntVec 4 W32) = 819+primOpTag (VecSubOp IntVec 2 W64) = 820+primOpTag (VecSubOp IntVec 32 W8) = 821+primOpTag (VecSubOp IntVec 16 W16) = 822+primOpTag (VecSubOp IntVec 8 W32) = 823+primOpTag (VecSubOp IntVec 4 W64) = 824+primOpTag (VecSubOp IntVec 64 W8) = 825+primOpTag (VecSubOp IntVec 32 W16) = 826+primOpTag (VecSubOp IntVec 16 W32) = 827+primOpTag (VecSubOp IntVec 8 W64) = 828+primOpTag (VecSubOp WordVec 16 W8) = 829+primOpTag (VecSubOp WordVec 8 W16) = 830+primOpTag (VecSubOp WordVec 4 W32) = 831+primOpTag (VecSubOp WordVec 2 W64) = 832+primOpTag (VecSubOp WordVec 32 W8) = 833+primOpTag (VecSubOp WordVec 16 W16) = 834+primOpTag (VecSubOp WordVec 8 W32) = 835+primOpTag (VecSubOp WordVec 4 W64) = 836+primOpTag (VecSubOp WordVec 64 W8) = 837+primOpTag (VecSubOp WordVec 32 W16) = 838+primOpTag (VecSubOp WordVec 16 W32) = 839+primOpTag (VecSubOp WordVec 8 W64) = 840+primOpTag (VecSubOp FloatVec 4 W32) = 841+primOpTag (VecSubOp FloatVec 2 W64) = 842+primOpTag (VecSubOp FloatVec 8 W32) = 843+primOpTag (VecSubOp FloatVec 4 W64) = 844+primOpTag (VecSubOp FloatVec 16 W32) = 845+primOpTag (VecSubOp FloatVec 8 W64) = 846+primOpTag (VecMulOp IntVec 16 W8) = 847+primOpTag (VecMulOp IntVec 8 W16) = 848+primOpTag (VecMulOp IntVec 4 W32) = 849+primOpTag (VecMulOp IntVec 2 W64) = 850+primOpTag (VecMulOp IntVec 32 W8) = 851+primOpTag (VecMulOp IntVec 16 W16) = 852+primOpTag (VecMulOp IntVec 8 W32) = 853+primOpTag (VecMulOp IntVec 4 W64) = 854+primOpTag (VecMulOp IntVec 64 W8) = 855+primOpTag (VecMulOp IntVec 32 W16) = 856+primOpTag (VecMulOp IntVec 16 W32) = 857+primOpTag (VecMulOp IntVec 8 W64) = 858+primOpTag (VecMulOp WordVec 16 W8) = 859+primOpTag (VecMulOp WordVec 8 W16) = 860+primOpTag (VecMulOp WordVec 4 W32) = 861+primOpTag (VecMulOp WordVec 2 W64) = 862+primOpTag (VecMulOp WordVec 32 W8) = 863+primOpTag (VecMulOp WordVec 16 W16) = 864+primOpTag (VecMulOp WordVec 8 W32) = 865+primOpTag (VecMulOp WordVec 4 W64) = 866+primOpTag (VecMulOp WordVec 64 W8) = 867+primOpTag (VecMulOp WordVec 32 W16) = 868+primOpTag (VecMulOp WordVec 16 W32) = 869+primOpTag (VecMulOp WordVec 8 W64) = 870+primOpTag (VecMulOp FloatVec 4 W32) = 871+primOpTag (VecMulOp FloatVec 2 W64) = 872+primOpTag (VecMulOp FloatVec 8 W32) = 873+primOpTag (VecMulOp FloatVec 4 W64) = 874+primOpTag (VecMulOp FloatVec 16 W32) = 875+primOpTag (VecMulOp FloatVec 8 W64) = 876+primOpTag (VecDivOp FloatVec 4 W32) = 877+primOpTag (VecDivOp FloatVec 2 W64) = 878+primOpTag (VecDivOp FloatVec 8 W32) = 879+primOpTag (VecDivOp FloatVec 4 W64) = 880+primOpTag (VecDivOp FloatVec 16 W32) = 881+primOpTag (VecDivOp FloatVec 8 W64) = 882+primOpTag (VecQuotOp IntVec 16 W8) = 883+primOpTag (VecQuotOp IntVec 8 W16) = 884+primOpTag (VecQuotOp IntVec 4 W32) = 885+primOpTag (VecQuotOp IntVec 2 W64) = 886+primOpTag (VecQuotOp IntVec 32 W8) = 887+primOpTag (VecQuotOp IntVec 16 W16) = 888+primOpTag (VecQuotOp IntVec 8 W32) = 889+primOpTag (VecQuotOp IntVec 4 W64) = 890+primOpTag (VecQuotOp IntVec 64 W8) = 891+primOpTag (VecQuotOp IntVec 32 W16) = 892+primOpTag (VecQuotOp IntVec 16 W32) = 893+primOpTag (VecQuotOp IntVec 8 W64) = 894+primOpTag (VecQuotOp WordVec 16 W8) = 895+primOpTag (VecQuotOp WordVec 8 W16) = 896+primOpTag (VecQuotOp WordVec 4 W32) = 897+primOpTag (VecQuotOp WordVec 2 W64) = 898+primOpTag (VecQuotOp WordVec 32 W8) = 899+primOpTag (VecQuotOp WordVec 16 W16) = 900+primOpTag (VecQuotOp WordVec 8 W32) = 901+primOpTag (VecQuotOp WordVec 4 W64) = 902+primOpTag (VecQuotOp WordVec 64 W8) = 903+primOpTag (VecQuotOp WordVec 32 W16) = 904+primOpTag (VecQuotOp WordVec 16 W32) = 905+primOpTag (VecQuotOp WordVec 8 W64) = 906+primOpTag (VecRemOp IntVec 16 W8) = 907+primOpTag (VecRemOp IntVec 8 W16) = 908+primOpTag (VecRemOp IntVec 4 W32) = 909+primOpTag (VecRemOp IntVec 2 W64) = 910+primOpTag (VecRemOp IntVec 32 W8) = 911+primOpTag (VecRemOp IntVec 16 W16) = 912+primOpTag (VecRemOp IntVec 8 W32) = 913+primOpTag (VecRemOp IntVec 4 W64) = 914+primOpTag (VecRemOp IntVec 64 W8) = 915+primOpTag (VecRemOp IntVec 32 W16) = 916+primOpTag (VecRemOp IntVec 16 W32) = 917+primOpTag (VecRemOp IntVec 8 W64) = 918+primOpTag (VecRemOp WordVec 16 W8) = 919+primOpTag (VecRemOp WordVec 8 W16) = 920+primOpTag (VecRemOp WordVec 4 W32) = 921+primOpTag (VecRemOp WordVec 2 W64) = 922+primOpTag (VecRemOp WordVec 32 W8) = 923+primOpTag (VecRemOp WordVec 16 W16) = 924+primOpTag (VecRemOp WordVec 8 W32) = 925+primOpTag (VecRemOp WordVec 4 W64) = 926+primOpTag (VecRemOp WordVec 64 W8) = 927+primOpTag (VecRemOp WordVec 32 W16) = 928+primOpTag (VecRemOp WordVec 16 W32) = 929+primOpTag (VecRemOp WordVec 8 W64) = 930+primOpTag (VecNegOp IntVec 16 W8) = 931+primOpTag (VecNegOp IntVec 8 W16) = 932+primOpTag (VecNegOp IntVec 4 W32) = 933+primOpTag (VecNegOp IntVec 2 W64) = 934+primOpTag (VecNegOp IntVec 32 W8) = 935+primOpTag (VecNegOp IntVec 16 W16) = 936+primOpTag (VecNegOp IntVec 8 W32) = 937+primOpTag (VecNegOp IntVec 4 W64) = 938+primOpTag (VecNegOp IntVec 64 W8) = 939+primOpTag (VecNegOp IntVec 32 W16) = 940+primOpTag (VecNegOp IntVec 16 W32) = 941+primOpTag (VecNegOp IntVec 8 W64) = 942+primOpTag (VecNegOp FloatVec 4 W32) = 943+primOpTag (VecNegOp FloatVec 2 W64) = 944+primOpTag (VecNegOp FloatVec 8 W32) = 945+primOpTag (VecNegOp FloatVec 4 W64) = 946+primOpTag (VecNegOp FloatVec 16 W32) = 947+primOpTag (VecNegOp FloatVec 8 W64) = 948+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 949+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 950+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 951+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 952+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 953+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 954+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 955+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 956+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 957+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 958+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 959+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 960+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 961+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 962+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 963+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 964+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 965+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 966+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 967+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 968+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 969+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 970+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 971+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 972+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 973+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 974+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 975+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 976+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 977+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 978+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 979+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 980+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 981+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 982+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 983+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 984+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 985+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 986+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 987+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 988+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 989+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 990+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 991+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 992+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 993+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 994+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 995+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 996+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 997+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 998+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 999+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1000+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1001+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1002+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1003+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1004+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1005+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1006+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1007+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1008+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1009+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1010+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1011+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1012+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1013+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1014+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1015+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1016+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1017+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1018+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1019+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1020+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1021+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1022+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1023+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1024+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1025+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1026+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1027+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1028+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1029+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1030+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1031+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1032+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1033+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1034+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1035+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1036+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1037+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1038+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1039+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1040+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1041+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1042+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1043+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1044+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1045+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1046+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1047+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1048+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1049+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1050+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1051+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1052+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1053+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1054+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1055+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1056+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1057+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1058+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1059+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1060+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1061+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1062+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1063+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1064+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1065+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1066+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1067+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1068+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1069+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1070+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1071+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1072+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1073+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1074+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1075+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1076+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1077+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1078+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1079+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1080+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1081+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1082+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1083+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1084+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1085+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1086+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1087+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1088+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1089+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1090+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1091+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1092+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1093+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1094+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1095+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1096+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1097+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1098+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1099+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1100+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1101+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1102+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1103+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1104+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1105+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1106+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1107+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1108+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1109+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1110+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1111+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1112+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1113+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1114+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1115+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1116+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1117+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1118+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1119+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1120+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1121+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1122+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1123+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1124+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1125+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1126+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1127+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1128+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1129+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1130+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1131+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1132+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1133+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1134+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1135+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1136+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1137+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1138+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1139+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1140+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1141+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1142+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1143+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1144+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1145+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1146+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1147+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1148+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1149+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1150+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1151+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1152+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1153+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1154+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1155+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1156+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1157+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1158+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1159+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1160+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1161+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1162+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1163+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1164+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1165+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1166+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1167+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1168+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1169+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1170+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1171+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1172+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1173+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1174+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1175+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1176+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1177+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1178+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1179+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1180+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1181+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1182+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1183+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1184+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1185+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1186+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1187+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1188+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1189+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1190+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1191+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1192+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1193+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1194+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1195+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1196+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1197+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1198+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1199+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1200+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1201+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1202+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1203+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1204+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1205+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1206+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1207+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1208+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1209+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1210+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1211+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1212+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1213+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1214+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1215+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1216+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1217+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1218+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1219+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1220+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1221+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1222+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1223+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1224+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1225+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1226+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1227+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1228+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1229+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1230+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1231+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1232+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1233+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1234+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1235+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1236+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1237+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1238+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1239+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1240+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1241+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1242+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1243+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1244+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1245+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1246+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1247+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1248+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1249+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1250+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1251+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1252+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1253+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1254+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1255+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1256+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1257+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1258+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1259+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1260+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1261+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1262+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1263+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1264+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1265+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1266+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1267+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1268+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1269+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1270+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1271+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1272+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1273+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1274+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1275+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1276+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1277+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1278+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1279+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1280+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1281+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1282+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1283+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1284+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1285+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1286+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1287+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1288+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1289+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1290+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1291+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1292+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1293+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1294+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1295+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1296+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1297+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1298+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1299+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1300+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1301+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1302+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1303+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1304+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1305+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1306+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1307+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1308+primOpTag PrefetchByteArrayOp3 = 1309+primOpTag PrefetchMutableByteArrayOp3 = 1310+primOpTag PrefetchAddrOp3 = 1311+primOpTag PrefetchValueOp3 = 1312+primOpTag PrefetchByteArrayOp2 = 1313+primOpTag PrefetchMutableByteArrayOp2 = 1314+primOpTag PrefetchAddrOp2 = 1315+primOpTag PrefetchValueOp2 = 1316+primOpTag PrefetchByteArrayOp1 = 1317+primOpTag PrefetchMutableByteArrayOp1 = 1318+primOpTag PrefetchAddrOp1 = 1319+primOpTag PrefetchValueOp1 = 1320+primOpTag PrefetchByteArrayOp0 = 1321+primOpTag PrefetchMutableByteArrayOp0 = 1322+primOpTag PrefetchAddrOp0 = 1323+primOpTag PrefetchValueOp0 = 1324
ghc-lib/stage0/lib/settings view
@@ -1,18 +1,17 @@-[("GCC extra via C opts", "")-,("C compiler command", "/usr/local/opt/ccache/libexec/gcc")-,("C compiler flags", "--target=x86_64-apple-darwin ")-,("C++ compiler command", "/usr/local/opt/ccache/libexec/g++")+[("C compiler command", "/usr/bin/gcc")+,("C compiler flags", "--target=x86_64-apple-darwin  -Qunused-arguments")+,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin   -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries")+,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains") ,("C compiler supports -no-pie", "NO")-,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") ,("ld command", "ld") ,("ld flags", "") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES")+,("ld supports response files", "NO") ,("ld is GNU ld", "NO")-,("ld supports single module", "NO") ,("Merge objects command", "ld") ,("Merge objects flags", "-r") ,("ar command", "/usr/bin/ar")@@ -35,7 +34,6 @@ ,("target has GNU nonexec stack", "NO") ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES")-,("target has RTS linker", "YES") ,("target has libm", "YES") ,("Unregisterised", "NO") ,("LLVM target", "x86_64-apple-darwin")
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "2b22b6ae69c94e721fde8af0108eb0feed97cc82"+cProjectGitCommitId   = "443e870d977b1ab6fc05f47a9a17bc49296adbd6"  cProjectVersion       :: String-cProjectVersion       = "9.6.7"+cProjectVersion       = "9.8.1"  cProjectVersionInt    :: String-cProjectVersionInt    = "906"+cProjectVersionInt    = "908"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "7"+cProjectPatchLevel    = "1"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "7"+cProjectPatchLevel1   = "1"  cProjectPatchLevel2   :: String cProjectPatchLevel2   = "0"
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -1,12 +1,5 @@ /* This file is created automatically.  Do not edit by hand.*/ -// MAX_Real_Vanilla_REG 6-// MAX_Real_Float_REG 6-// MAX_Real_Double_REG 6-// MAX_Real_Long_REG 0-// WORD_SIZE 8-// BITMAP_BITS_SHIFT 6-// TAG_BITS 3 #define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,104,120,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -106,36 +106,36 @@ /* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 -/* Define to 1 if you have the 'clock_gettime' function. */+/* Define to 1 if you have the `clock_gettime' function. */ #define HAVE_CLOCK_GETTIME 1 -/* Define to 1 if you have the 'ctime_r' function. */+/* Define to 1 if you have the `ctime_r' function. */ #define HAVE_CTIME_R 1  /* Define to 1 if you have the <ctype.h> header file. */ #define HAVE_CTYPE_H 1 -/* Define to 1 if you have the declaration of 'ctime_r', and to 0 if you+/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you    don't. */ #define HAVE_DECL_CTIME_R 1 -/* Define to 1 if you have the declaration of 'environ', and to 0 if you+/* Define to 1 if you have the declaration of `environ', and to 0 if you    don't. */ #define HAVE_DECL_ENVIRON 0 -/* Define to 1 if you have the declaration of 'MADV_DONTNEED', and to 0 if you+/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you    don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */ -/* Define to 1 if you have the declaration of 'MADV_FREE', and to 0 if you+/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you    don't. */ /* #undef HAVE_DECL_MADV_FREE */ -/* Define to 1 if you have the declaration of 'MAP_NORESERVE', and to 0 if you+/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you    don't. */ /* #undef HAVE_DECL_MAP_NORESERVE */ -/* Define to 1 if you have the declaration of 'program_invocation_short_name',+/* Define to 1 if you have the declaration of `program_invocation_short_name',    and to 0 if you don't. */ #define HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME 0 @@ -145,7 +145,7 @@ /* Define to 1 if you have the <dlfcn.h> header file. */ #define HAVE_DLFCN_H 1 -/* Define to 1 if you have the 'dlinfo' function. */+/* Define to 1 if you have the `dlinfo' function. */ /* #undef HAVE_DLINFO */  /* Define to 1 if you have the <elfutils/libdw.h> header file. */@@ -154,7 +154,7 @@ /* Define to 1 if you have the <errno.h> header file. */ #define HAVE_ERRNO_H 1 -/* Define to 1 if you have the 'eventfd' function. */+/* Define to 1 if you have the `eventfd' function. */ /* #undef HAVE_EVENTFD */  /* Define to 1 if you have the <fcntl.h> header file. */@@ -163,25 +163,25 @@ /* Define to 1 if you have the <ffi.h> header file. */ /* #undef HAVE_FFI_H */ -/* Define to 1 if you have the 'fork' function. */+/* Define to 1 if you have the `fork' function. */ #define HAVE_FORK 1 -/* Define to 1 if you have the 'getclock' function. */+/* Define to 1 if you have the `getclock' function. */ /* #undef HAVE_GETCLOCK */  /* Define to 1 if you have the `GetModuleFileName' function. */ /* #undef HAVE_GETMODULEFILENAME */ -/* Define to 1 if you have the 'getpid' function. */+/* Define to 1 if you have the `getpid' function. */ #define HAVE_GETPID 1 -/* Define to 1 if you have the 'getrusage' function. */+/* Define to 1 if you have the `getrusage' function. */ #define HAVE_GETRUSAGE 1 -/* Define to 1 if you have the 'gettimeofday' function. */+/* Define to 1 if you have the `gettimeofday' function. */ #define HAVE_GETTIMEOFDAY 1 -/* Define to 1 if you have the 'getuid' function. */+/* Define to 1 if you have the `getuid' function. */ #define HAVE_GETUID 1  /* Define to 1 if you have the <grp.h> header file. */@@ -190,37 +190,41 @@ /* Define to 1 if you have the <inttypes.h> header file. */ #define HAVE_INTTYPES_H 1 -/* Define to 1 if you have the 'bfd' library (-lbfd). */+/* Define to 1 if you have the `bfd' library (-lbfd). */ /* #undef HAVE_LIBBFD */ -/* Define to 1 if you have the 'dl' library (-ldl). */+/* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 -/* Define to 1 if you have the 'iberty' library (-liberty). */+/* Define to 1 if you have the `iberty' library (-liberty). */ /* #undef HAVE_LIBIBERTY */  /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 -/* Define to 1 if you have the 'mingwex' library (-lmingwex). */+/* Define to 1 if you have the `mingwex' library (-lmingwex). */ /* #undef HAVE_LIBMINGWEX */  /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 -/* Define to 1 if you have the 'pthread' library (-lpthread). */+/* Define to 1 if you have the `pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 -/* Define to 1 if you have the 'rt' library (-lrt). */+/* Define to 1 if you have the `rt' library (-lrt). */ /* #undef HAVE_LIBRT */ +/* Define to 1 if you wish to compress IPE data in compiler results (requires+   libzstd) */+#define HAVE_LIBZSTD 0+ /* Define to 1 if you have the <limits.h> header file. */ #define HAVE_LIMITS_H 1  /* Define to 1 if you have the <locale.h> header file. */ #define HAVE_LOCALE_H 1 -/* Define to 1 if the system has the type 'long long'. */+/* Define to 1 if the system has the type `long long'. */ #define HAVE_LONG_LONG 1  /* Define to 1 if you have the <minix/config.h> header file. */@@ -238,7 +242,7 @@ /* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */ #define HAVE_PRINTF_LDBLSTUB 0 -/* Define to 1 if you have the 'pthread_condattr_setclock' function. */+/* Define to 1 if you have the `pthread_condattr_setclock' function. */ /* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */  /* Define to 1 if you have the <pthread.h> header file. */@@ -262,25 +266,25 @@ /* Define to 1 if you have the <pwd.h> header file. */ #define HAVE_PWD_H 1 -/* Define to 1 if you have the 'raise' function. */+/* Define to 1 if you have the `raise' function. */ #define HAVE_RAISE 1 -/* Define to 1 if you have the 'sched_getaffinity' function. */+/* Define to 1 if you have the `sched_getaffinity' function. */ /* #undef HAVE_SCHED_GETAFFINITY */  /* Define to 1 if you have the <sched.h> header file. */ #define HAVE_SCHED_H 1 -/* Define to 1 if you have the 'sched_setaffinity' function. */+/* Define to 1 if you have the `sched_setaffinity' function. */ /* #undef HAVE_SCHED_SETAFFINITY */ -/* Define to 1 if you have the 'setitimer' function. */+/* Define to 1 if you have the `setitimer' function. */ #define HAVE_SETITIMER 1 -/* Define to 1 if you have the 'setlocale' function. */+/* Define to 1 if you have the `setlocale' function. */ #define HAVE_SETLOCALE 1 -/* Define to 1 if you have the 'siginterrupt' function. */+/* Define to 1 if you have the `siginterrupt' function. */ #define HAVE_SIGINTERRUPT 1  /* Define to 1 if you have the <signal.h> header file. */@@ -304,7 +308,7 @@ /* Define to 1 if Apple-style dead-stripping is supported. */ #define HAVE_SUBSECTIONS_VIA_SYMBOLS 1 -/* Define to 1 if you have the 'sysconf' function. */+/* Define to 1 if you have the `sysconf' function. */ #define HAVE_SYSCONF 1  /* Define to 1 if you have libffi. */@@ -358,22 +362,22 @@ /* Define to 1 if you have the <termios.h> header file. */ #define HAVE_TERMIOS_H 1 -/* Define to 1 if you have the 'timer_settime' function. */+/* Define to 1 if you have the `timer_settime' function. */ /* #undef HAVE_TIMER_SETTIME */ -/* Define to 1 if you have the 'times' function. */+/* Define to 1 if you have the `times' function. */ #define HAVE_TIMES 1  /* Define to 1 if you have the <unistd.h> header file. */ #define HAVE_UNISTD_H 1 -/* Define to 1 if you have the 'uselocale' function. */+/* Define to 1 if you have the `uselocale' function. */ #define HAVE_USELOCALE 1  /* Define to 1 if you have the <utime.h> header file. */ #define HAVE_UTIME_H 1 -/* Define to 1 if you have the 'vfork' function. */+/* Define to 1 if you have the `vfork' function. */ #define HAVE_VFORK 1  /* Define to 1 if you have the <vfork.h> header file. */@@ -391,12 +395,15 @@ /* Define to 1 if you have the <winsock.h> header file. */ /* #undef HAVE_WINSOCK_H */ -/* Define to 1 if 'fork' works. */+/* Define to 1 if `fork' works. */ #define HAVE_WORKING_FORK 1 -/* Define to 1 if 'vfork' works. */+/* Define to 1 if `vfork' works. */ #define HAVE_WORKING_VFORK 1 +/* Define to 1 if you have the <zstd.h> header file. */+/* #undef HAVE_ZSTD_H */+ /* Define to 1 if C symbols have a leading underscore added by the compiler.    */ #define LEADING_UNDERSCORE 1@@ -428,67 +435,67 @@ /* Use mmap in the runtime linker */ #define RTS_LINKER_USE_MMAP 1 -/* The size of 'char', as computed by sizeof. */+/* The size of `char', as computed by sizeof. */ #define SIZEOF_CHAR 1 -/* The size of 'double', as computed by sizeof. */+/* The size of `double', as computed by sizeof. */ #define SIZEOF_DOUBLE 8 -/* The size of 'float', as computed by sizeof. */+/* The size of `float', as computed by sizeof. */ #define SIZEOF_FLOAT 4 -/* The size of 'int', as computed by sizeof. */+/* The size of `int', as computed by sizeof. */ #define SIZEOF_INT 4 -/* The size of 'int16_t', as computed by sizeof. */+/* The size of `int16_t', as computed by sizeof. */ #define SIZEOF_INT16_T 2 -/* The size of 'int32_t', as computed by sizeof. */+/* The size of `int32_t', as computed by sizeof. */ #define SIZEOF_INT32_T 4 -/* The size of 'int64_t', as computed by sizeof. */+/* The size of `int64_t', as computed by sizeof. */ #define SIZEOF_INT64_T 8 -/* The size of 'int8_t', as computed by sizeof. */+/* The size of `int8_t', as computed by sizeof. */ #define SIZEOF_INT8_T 1 -/* The size of 'long', as computed by sizeof. */+/* The size of `long', as computed by sizeof. */ #define SIZEOF_LONG 8 -/* The size of 'long long', as computed by sizeof. */+/* The size of `long long', as computed by sizeof. */ #define SIZEOF_LONG_LONG 8 -/* The size of 'short', as computed by sizeof. */+/* The size of `short', as computed by sizeof. */ #define SIZEOF_SHORT 2 -/* The size of 'uint16_t', as computed by sizeof. */+/* The size of `uint16_t', as computed by sizeof. */ #define SIZEOF_UINT16_T 2 -/* The size of 'uint32_t', as computed by sizeof. */+/* The size of `uint32_t', as computed by sizeof. */ #define SIZEOF_UINT32_T 4 -/* The size of 'uint64_t', as computed by sizeof. */+/* The size of `uint64_t', as computed by sizeof. */ #define SIZEOF_UINT64_T 8 -/* The size of 'uint8_t', as computed by sizeof. */+/* The size of `uint8_t', as computed by sizeof. */ #define SIZEOF_UINT8_T 1 -/* The size of 'unsigned char', as computed by sizeof. */+/* The size of `unsigned char', as computed by sizeof. */ #define SIZEOF_UNSIGNED_CHAR 1 -/* The size of 'unsigned int', as computed by sizeof. */+/* The size of `unsigned int', as computed by sizeof. */ #define SIZEOF_UNSIGNED_INT 4 -/* The size of 'unsigned long', as computed by sizeof. */+/* The size of `unsigned long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG 8 -/* The size of 'unsigned long long', as computed by sizeof. */+/* The size of `unsigned long long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG_LONG 8 -/* The size of 'unsigned short', as computed by sizeof. */+/* The size of `unsigned short', as computed by sizeof. */ #define SIZEOF_UNSIGNED_SHORT 2 -/* The size of 'void *', as computed by sizeof. */+/* The size of `void *', as computed by sizeof. */ #define SIZEOF_VOID_P 8  /* If using the C implementation of alloca, define if you know the@@ -499,7 +506,11 @@ 	STACK_DIRECTION = 0 => direction of growth unknown */ /* #undef STACK_DIRECTION */ -/* Define to 1 if all of the C89 standard headers exist (not just the ones+/* Define to 1 if you wish to statically link the libzstd compression library+   in the compiler (requires libzstd) */+#define STATIC_LIBZSTD 0++/* Define to 1 if all of the C90 standard headers exist (not just the ones    required in a freestanding environment). This macro is provided for    backward compatibility; new code need not use it. */ #define STDC_HEADERS 1@@ -516,7 +527,7 @@ /* Set to 1 to use libdw */ #define USE_LIBDW 0 -/* Enable extensions on AIX, Interix, z/OS.  */+/* Enable extensions on AIX 3, Interix.  */ #ifndef _ALL_SOURCE # define _ALL_SOURCE 1 #endif@@ -577,15 +588,11 @@ #ifndef __STDC_WANT_IEC_60559_DFP_EXT__ # define __STDC_WANT_IEC_60559_DFP_EXT__ 1 #endif-/* Enable extensions specified by C23 Annex F.  */-#ifndef __STDC_WANT_IEC_60559_EXT__-# define __STDC_WANT_IEC_60559_EXT__ 1-#endif /* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */ #ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__ # define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1 #endif-/* Enable extensions specified by C23 Annex H and ISO/IEC TS 18661-3:2015.  */+/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */ #ifndef __STDC_WANT_IEC_60559_TYPES_EXT__ # define __STDC_WANT_IEC_60559_TYPES_EXT__ 1 #endif@@ -626,22 +633,16 @@ /* Number of bits in a file offset, on hosts where this is settable. */ /* #undef _FILE_OFFSET_BITS */ -/* Define to 1 on platforms where this makes off_t a 64-bit type. */+/* Define for large files, on AIX-style hosts. */ /* #undef _LARGE_FILES */ -/* Number of bits in time_t, on hosts where this is settable. */-/* #undef _TIME_BITS */--/* Define to 1 on platforms where this makes time_t a 64-bit type. */-/* #undef __MINGW_USE_VC2005_COMPAT */- /* ARM pre v6 */ /* #undef arm_HOST_ARCH_PRE_ARMv6 */  /* ARM pre v7 */ /* #undef arm_HOST_ARCH_PRE_ARMv7 */ -/* Define to empty if 'const' does not conform to ANSI C. */+/* Define to empty if `const' does not conform to ANSI C. */ /* #undef const */  /* Define as a signed integer type capable of holding a process identifier. */@@ -653,9 +654,35 @@ /* The minimum supported LLVM version number */ #define sUPPORTED_LLVM_VERSION_MIN (11) -/* Define as 'unsigned int' if <stddef.h> doesn't define. */+/* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */ -/* Define as 'fork' if 'vfork' does not work. */+/* Define as `fork' if `vfork' does not work. */ /* #undef vfork */+/* ghcautoconf.h.autoconf.  Generated from ghcautoconf.h.autoconf.in by configure.  */+/* ghcautoconf.h.autoconf.in.  Generated from configure.ac by autoheader.  */++/* Define to the address where bug reports for this package should be sent. */+/* #undef PACKAGE_BUGREPORT */++/* Define to the full name of this package. */+/* #undef PACKAGE_NAME */++/* Define to the full name and version of this package. */+/* #undef PACKAGE_STRING */++/* Define to the one symbol short name of this package. */+/* #undef PACKAGE_TARNAME */++/* Define to the home page for this package. */+/* #undef PACKAGE_URL */++/* Define to the version of this package. */+/* #undef PACKAGE_VERSION */++/* ARM pre v6 */+/* #undef arm_HOST_ARCH_PRE_ARMv6 */++/* ARM pre v7 */+/* #undef arm_HOST_ARCH_PRE_ARMv7 */ #endif /* __GHCAUTOCONF_H__ */
ghc/ghc-bin.cabal view
@@ -2,7 +2,7 @@ -- ./configure.  Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal.  Name: ghc-bin-Version: 9.6.7+Version: 9.8.1 Copyright: XXX -- License: XXX -- License-File: XXX@@ -33,14 +33,14 @@     Main-Is: Main.hs     Build-Depends: base       >= 4   && < 5,                    array      >= 0.1 && < 0.6,-                   bytestring >= 0.9 && < 0.12,+                   bytestring >= 0.9 && < 0.13,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,                    filepath   >= 1   && < 1.5,                    containers >= 0.5 && < 0.7,                    transformers >= 0.5 && < 0.7,-                   ghc-boot      == 9.6.7,-                   ghc           == 9.6.7+                   ghc-boot      == 9.8.1,+                   ghc           == 9.8.1      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.14@@ -56,9 +56,9 @@     if flag(internal-interpreter)         -- NB: this is never built by the bootstrapping GHC+libraries         Build-depends:-            deepseq        == 1.4.*,-            ghc-prim       >= 0.5.0 && < 0.11,-            ghci           == 9.6.7,+            deepseq        >= 1.4 && < 1.6,+            ghc-prim       >= 0.5.0 && < 0.12,+            ghci           == 9.8.1,             haskeline      == 0.8.*,             exceptions     == 0.10.*,             time           >= 1.8 && < 1.13@@ -68,7 +68,7 @@             GHCi.UI             GHCi.UI.Info             GHCi.UI.Monad-            GHCi.UI.Tags+            GHCi.UI.Exception             GHCi.Util         Other-Extensions:             FlexibleInstances
+ libraries/containers/containers/include/containers.h view
@@ -0,0 +1,30 @@+/*+ * Common macros for containers+ */++#ifndef HASKELL_CONTAINERS_H+#define HASKELL_CONTAINERS_H++/*+ * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+ */+#ifdef __GLASGOW_HASKELL__+#include "MachDeps.h"+#endif++#ifdef __GLASGOW_HASKELL__+#define DEFINE_PATTERN_SYNONYMS 1+#endif++#ifdef __GLASGOW_HASKELL__+# define USE_ST_MONAD 1+#ifndef WORDS_BIGENDIAN+/*+ * Unboxed arrays are broken on big-endian architectures.+ * See https://gitlab.haskell.org/ghc/ghc/-/issues/16998+ */+# define USE_UNBOXED_ARRAYS 1+#endif+#endif++#endif
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs view
@@ -151,6 +151,8 @@    | FieldSelectors    | OverloadedRecordDot    | OverloadedRecordUpdate+   | TypeAbstractions+   | ExtendedLiterals    deriving (Eq, Enum, Show, Generic, Bounded) -- 'Ord' and 'Bounded' are provided for GHC API users (see discussions -- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
libraries/ghc-boot-th/ghc-boot-th.cabal view
@@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal.  name:           ghc-boot-th-version:        9.6.7+version:        9.8.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -36,4 +36,4 @@             GHC.ForeignSrcLang.Type             GHC.Lexeme -    build-depends: base       >= 4.7 && < 4.19+    build-depends: base       >= 4.7 && < 4.20
libraries/ghc-boot/GHC/BaseDir.hs view
@@ -12,7 +12,11 @@ -- installation location at build time. ghc-pkg also can expand those variables -- and so needs the top dir location to do that too. -module GHC.BaseDir where+module GHC.BaseDir+  ( expandTopDir+  , expandPathVar+  , getBaseDir+  ) where  import Prelude -- See Note [Why do we import Prelude here?] @@ -20,11 +24,9 @@ import Data.Maybe (listToMaybe) import System.FilePath --- Windows-#if defined(mingw32_HOST_OS)-import System.Environment (getExecutablePath)--- POSIX-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS)+#if MIN_VERSION_base(4,17,0) && !defined(openbsd_HOST_OS)+import System.Environment (executablePath)+#else import System.Environment (getExecutablePath) #endif @@ -43,17 +45,29 @@ expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = [] +#if !MIN_VERSION_base(4,17,0) || defined(openbsd_HOST_OS)+-- Polyfill for base-4.17 executablePath and OpenBSD which doesn't+-- have executablePath. The best it can do is use argv[0] which is+-- good enough for most uses of getBaseDir.+executablePath :: Maybe (IO (Maybe FilePath))+executablePath = Just (Just <$> getExecutablePath)+#elif !MIN_VERSION_base(4,18,0) && defined(js_HOST_ARCH)+-- executablePath is missing from base < 4.18.0 on js_HOST_ARCH+executablePath :: Maybe (IO (Maybe FilePath))+executablePath = Nothing+#endif+ -- | Calculate the location of the base dir getBaseDir :: IO (Maybe String) #if defined(mingw32_HOST_OS)-getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath+getBaseDir = maybe (pure Nothing) ((((</> "lib") . rootDir) <$>) <$>) executablePath   where     -- locate the "base dir" when given the path     -- to the real ghc executable (as opposed to symlink)     -- that is running this function.     rootDir :: FilePath -> FilePath     rootDir = takeDirectory . takeDirectory . normalise-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS)+#else -- on unix, this is a bit more confusing. -- The layout right now is something like --@@ -65,14 +79,15 @@ -- As such, we first need to find the absolute location to the -- binary. ----- getExecutablePath will return (3). One takeDirectory will+-- executablePath will return (3). One takeDirectory will -- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). -- -- This of course only works due to the current layout. If -- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} -- this would need to be changed accordingly. ---getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath-#else-getBaseDir = return Nothing+getBaseDir = maybe (pure Nothing) ((((</> "lib") . rootDir) <$>) <$>) executablePath+  where+    rootDir :: FilePath -> FilePath+    rootDir = takeDirectory . takeDirectory #endif
libraries/ghc-boot/ghc-boot.cabal view
@@ -5,7 +5,7 @@ -- ghc-boot.cabal.  name:           ghc-boot-version:        9.6.7+version:        9.8.1 license:        BSD-3-Clause license-file:   LICENSE category:       GHC@@ -70,14 +70,14 @@             GHC.Version             GHC.Platform.Host -    build-depends: base       >= 4.7 && < 4.19,+    build-depends: base       >= 4.7 && < 4.20,                    binary     == 0.8.*,-                   bytestring >= 0.10 && < 0.12,+                   bytestring >= 0.10 && < 0.13,                    containers >= 0.5 && < 0.7,                    directory  >= 1.2 && < 1.4,                    filepath   >= 1.3 && < 1.5,-                   deepseq    >= 1.4 && < 1.5,-                   ghc-boot-th == 9.6.7+                   deepseq    >= 1.4 && < 1.6,+                   ghc-boot-th == 9.8.1     if !os(windows)         build-depends:                    unix       >= 2.7 && < 2.9
libraries/ghc-heap/GHC/Exts/Heap.hs view
@@ -120,7 +120,7 @@  instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where     getClosureData x = return $-        AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }+        AddrClosure { ptipe = PAddr, addrVal = Ptr x }  instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where     getClosureData x = return $
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view
@@ -329,7 +329,7 @@     -- | Primitive Addr   | AddrClosure         { ptipe      :: PrimType-        , addrVal    :: !Int }+        , addrVal    :: !(Ptr ()) }      -- | Primitive Float   | FloatClosure
libraries/ghc-heap/ghc-heap.cabal view
@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.6.7+version:        9.8.1 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org@@ -23,7 +23,7 @@   default-language: Haskell2010    build-depends:    base             >= 4.9.0 && < 5.0-                  , ghc-prim         > 0.2 && < 0.11+                  , ghc-prim         > 0.2 && < 0.12                   , rts              == 1.0.*                   , containers       >= 0.6.2.1 && < 0.7
− libraries/ghci/GHCi/BinaryArray.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}--- | Efficient serialisation for GHCi Instruction arrays------ Author: Ben Gamari----module GHCi.BinaryArray(putArray, getArray) where--import Prelude-import Foreign.Ptr-import Data.Binary-import Data.Binary.Put (putBuilder)-import qualified Data.Binary.Get.Internal as Binary-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Builder.Internal as BB-import qualified Data.Array.Base as A-import qualified Data.Array.IO.Internals as A-import qualified Data.Array.Unboxed as A-import GHC.Exts-import GHC.IO---- | An efficient serialiser of 'A.UArray'.-putArray :: Binary i => A.UArray i a -> Put-putArray (A.UArray l u _ arr#) = do-    put l-    put u-    putBuilder $ byteArrayBuilder arr#--byteArrayBuilder :: ByteArray# -> BB.Builder-byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))-  where-    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a-    go !inStart !inEnd k (BB.BufferRange outStart outEnd)-      -- There is enough room in this output buffer to write all remaining array-      -- contents-      | inRemaining <= outRemaining = do-          copyByteArrayToAddr arr# inStart outStart inRemaining-          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)-      -- There is only enough space for a fraction of the remaining contents-      | otherwise = do-          copyByteArrayToAddr arr# inStart outStart outRemaining-          let !inStart' = inStart + outRemaining-          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)-      where-        inRemaining  = inEnd - inStart-        outRemaining = outEnd `minusPtr` outStart--    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()-    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =-        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of-                     s' -> (# s', () #)---- | An efficient deserialiser of 'A.UArray'.-getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)-getArray = do-    l <- get-    u <- get-    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <--        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)-    let go 0 _ = return ()-        go !remaining !off = do-            Binary.readNWith n $ \ptr ->-              copyAddrToByteArray ptr arr# off n-            go (remaining - n) (off + n)-          where n = min chunkSize remaining-    go (I# (sizeofMutableByteArray# arr#)) 0-    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr-  where-    chunkSize = 10*1024--    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld-                        -> Int -> Int -> IO ()-    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =-        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of-                     s' -> (# s', () #)---- this is inexplicably not exported in currently released array versions-unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)-unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
libraries/ghci/GHCi/Message.hs view
@@ -21,7 +21,6 @@   , QState(..)   , getMessage, putMessage, getTHMessage, putTHMessage   , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe-  , BreakModule   ) where  import Prelude -- See note [Why do we import Prelude here?]@@ -227,12 +226,6 @@     :: RemoteRef (ResumeContext ())     -> Message (EvalStatus ()) -  -- | Allocate a string for a breakpoint module name.-  -- This uses an empty dummy type because @ModuleName@ isn't available here.-  NewBreakModule-   :: String-   -> Message (RemotePtr BreakModule)- deriving instance Show (Message a)  @@ -387,7 +380,7 @@   | EvalBreak Bool        HValueRef{- AP_STACK -}        Int {- break index -}-       String {- module name -}+       Int {- uniq of ModuleName -}        (RemoteRef (ResumeContext b))        (RemotePtr CostCentreStack) -- Cost centre stack   deriving (Generic, Show)@@ -401,10 +394,6 @@  instance Binary a => Binary (EvalResult a) --- | A dummy type that tags the pointer to a breakpoint's @ModuleName@, because--- that type isn't available here.-data BreakModule- -- SomeException can't be serialized because it contains dynamic -- types.  However, we do very limited things with the exceptions that -- are thrown by interpreted computations:@@ -475,8 +464,8 @@ #ifndef MIN_VERSION_ghc_heap #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \-  (major1) == 9 && (major2) <  6 || \-  (major1) == 9 && (major2) == 6 && (minor) <= 7)+  (major1) == 9 && (major2) <  8 || \+  (major1) == 9 && (major2) == 8 && (minor) <= 1) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo@@ -538,7 +527,6 @@       36 -> Msg <$> (Seq <$> get)       37 -> Msg <$> return RtsRevertCAFs       38 -> Msg <$> (ResumeSeq <$> get)-      39 -> Msg <$> (NewBreakModule <$> get)       _  -> error $ "Unknown Message code " ++ (show b)  putMessage :: Message a -> Put@@ -582,7 +570,6 @@   Seq a                       -> putWord8 36 >> put a   RtsRevertCAFs               -> putWord8 37   ResumeSeq a                 -> putWord8 38 >> put a-  NewBreakModule name         -> putWord8 39 >> put name  -- ----------------------------------------------------------------------------- -- Reading/writing messages
libraries/ghci/GHCi/RemoteTypes.hs view
@@ -8,14 +8,29 @@ -- compiler/GHC/Runtime/Interpreter.hs. -- module GHCi.RemoteTypes-  ( RemotePtr(..), toRemotePtr, fromRemotePtr, castRemotePtr+  ( -- * Remote pointer+    RemotePtr(..)+  , toRemotePtr+  , fromRemotePtr+  , castRemotePtr+  -- * RemoteRef: reference to some heap object (potentially remote)+  , RemoteRef (..)+  , mkRemoteRef+  , localRef+  , freeRemoteRef+  , castRemoteRef+  -- * ForeignRef: RemoteRef with a finalizer+  , ForeignRef+  , mkForeignRef+  , withForeignRef+  , finalizeForeignRef+  , castForeignRef+  , unsafeForeignRefToRemoteRef+  -- * HValue   , HValue(..)-  , RemoteRef, mkRemoteRef, localRef, freeRemoteRef-  , HValueRef, toHValueRef-  , ForeignRef, mkForeignRef, withForeignRef+  , HValueRef   , ForeignHValue-  , unsafeForeignRefToRemoteRef, finalizeForeignRef-  ) where+) where  import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq@@ -23,7 +38,6 @@ import Foreign hiding (newForeignPtr) import Foreign.Concurrent import Data.Binary-import Unsafe.Coerce import GHC.Exts import GHC.ForeignPtr @@ -52,23 +66,28 @@ deriving instance NFData (RemotePtr a)  -- -------------------------------------------------------------------------------- HValueRef+-- HValue: alias for Any  newtype HValue = HValue Any  instance Show HValue where   show _ = "<HValue>" --- | A reference to a remote value.  These are allocated and freed explicitly.+-- For convenience+type HValueRef     = RemoteRef HValue+type ForeignHValue = ForeignRef HValue++-- -----------------------------------------------------------------------------+-- RemoteRef: pointer to a Heap object++-- | A reference to a heap object. Potentially in a remote heap!+-- These are allocated and freed explicitly. newtype RemoteRef a = RemoteRef (RemotePtr ())   deriving (Show, Binary)  -- We can discard type information if we want-toHValueRef :: RemoteRef a -> RemoteRef HValue-toHValueRef = unsafeCoerce---- For convenience-type HValueRef = RemoteRef HValue+castRemoteRef :: RemoteRef a -> RemoteRef b+castRemoteRef = coerce  -- | Make a reference to a local value that we can send remotely. -- This reference will keep the value that it refers to alive until@@ -78,34 +97,33 @@   sp <- newStablePtr a   return $! RemoteRef (toRemotePtr (castStablePtrToPtr sp)) --- | Convert an HValueRef to an HValue.  Should only be used if the HValue--- originated in this process.+-- | Convert a RemoteRef to its carried type. Should only be used if the+-- RemoteRef originated in this process. localRef :: RemoteRef a -> IO a localRef (RemoteRef w) =   deRefStablePtr (castPtrToStablePtr (fromRemotePtr w)) --- | Release an HValueRef that originated in this process+-- | Release a RemoteRef that originated in this process freeRemoteRef :: RemoteRef a -> IO () freeRemoteRef (RemoteRef w) =   freeStablePtr (castPtrToStablePtr (fromRemotePtr w)) --- | An HValueRef with a finalizer+-- | An RemoteRef with a finalizer newtype ForeignRef a = ForeignRef (ForeignPtr ())  instance NFData (ForeignRef a) where   rnf x = x `seq` () -type ForeignHValue = ForeignRef HValue  -- | Create a 'ForeignRef' from a 'RemoteRef'.  The finalizer--- should arrange to call 'freeHValueRef' on the 'HValueRef'.  (since+-- should arrange to call 'freeRemoteRef' on the 'RemoteRef'.  (since -- this function needs to be called in the process that created the--- 'HValueRef', it cannot be called directly from the finalizer).+-- 'RemoteRef', it cannot be called directly from the finalizer). mkForeignRef :: RemoteRef a -> IO () -> IO (ForeignRef a) mkForeignRef (RemoteRef hvref) finalizer =   ForeignRef <$> newForeignPtr (fromRemotePtr hvref) finalizer --- | Use a 'ForeignHValue'+-- | Use a 'ForeignRef' withForeignRef :: ForeignRef a -> (RemoteRef a -> IO b) -> IO b withForeignRef (ForeignRef fp) f =    withForeignPtr fp (f . RemoteRef . toRemotePtr)@@ -116,3 +134,6 @@  finalizeForeignRef :: ForeignRef a -> IO () finalizeForeignRef (ForeignRef fp) = finalizeForeignPtr fp++castForeignRef :: ForeignRef a -> ForeignRef b+castForeignRef = coerce
− libraries/ghci/GHCi/ResolvedBCO.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,-    BangPatterns, CPP #-}-module GHCi.ResolvedBCO-  ( ResolvedBCO(..)-  , ResolvedBCOPtr(..)-  , isLittleEndian-  ) where--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Data.SizedSeq-import GHCi.RemoteTypes-import GHCi.BreakArray--import Data.Array.Unboxed-import Data.Binary-import GHC.Generics-import GHCi.BinaryArray---#include "MachDeps.h"--isLittleEndian :: Bool-#if defined(WORDS_BIGENDIAN)-isLittleEndian = False-#else-isLittleEndian = True-#endif---- -------------------------------------------------------------------------------- ResolvedBCO---- | A 'ResolvedBCO' is one in which all the 'Name' references have been--- resolved to actual addresses or 'RemoteHValues'.------ Note, all arrays are zero-indexed (we assume this when--- serializing/deserializing)-data ResolvedBCO-   = ResolvedBCO {-        resolvedBCOIsLE   :: Bool,-        resolvedBCOArity  :: {-# UNPACK #-} !Int,-        resolvedBCOInstrs :: UArray Int Word16,         -- insns-        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap-        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs-        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs-   }-   deriving (Generic, Show)---- | The Binary instance for ResolvedBCOs.------ Note, that we do encode the endianness, however there is no support for mixed--- endianness setups.  This is primarily to ensure that ghc and iserv share the--- same endianness.-instance Binary ResolvedBCO where-  put ResolvedBCO{..} = do-    put resolvedBCOIsLE-    put resolvedBCOArity-    putArray resolvedBCOInstrs-    putArray resolvedBCOBitmap-    putArray resolvedBCOLits-    put resolvedBCOPtrs-  get = ResolvedBCO-        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get--data ResolvedBCOPtr-  = ResolvedBCORef {-# UNPACK #-} !Int-      -- ^ reference to the Nth BCO in the current set-  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)-      -- ^ reference to a previously created BCO-  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())-      -- ^ reference to a static ptr-  | ResolvedBCOPtrBCO ResolvedBCO-      -- ^ a nested BCO-  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)-      -- ^ Resolves to the MutableArray# inside the BreakArray-  deriving (Generic, Show)--instance Binary ResolvedBCOPtr
libraries/ghci/GHCi/TH/Binary.hs view
@@ -27,6 +27,7 @@ instance Binary TH.Type instance Binary TH.TyLit instance Binary TH.Specificity+instance Binary TH.BndrVis instance Binary flag => Binary (TH.TyVarBndr flag) instance Binary TH.Role instance Binary TH.Lit
libraries/ghci/ghci.cabal view
@@ -2,7 +2,7 @@ -- ../../configure.  Make sure you are editing ghci.cabal.in, not ghci.cabal.  name:           ghci-version:        9.6.7+version:        9.8.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -50,14 +50,18 @@     if flag(internal-interpreter)         CPP-Options: -DHAVE_INTERNAL_INTERPRETER         exposed-modules:-            GHCi.InfoTable             GHCi.Run             GHCi.CreateBCO             GHCi.ObjLink             GHCi.Signals             GHCi.StaticPtrTable             GHCi.TH+            GHCi.Server +        if !arch(javascript)+          exposed-modules:+            GHCi.InfoTable+     exposed-modules:         GHCi.BreakArray         GHCi.BinaryArray@@ -66,20 +70,21 @@         GHCi.RemoteTypes         GHCi.FFI         GHCi.TH.Binary+        GHCi.Utils      Build-Depends:         rts,         array            == 0.5.*,-        base             >= 4.8 && < 4.19,-        ghc-prim         >= 0.5.0 && < 0.11,+        base             >= 4.8 && < 4.20,+        ghc-prim         >= 0.5.0 && < 0.12,         binary           == 0.8.*,-        bytestring       >= 0.10 && < 0.12,+        bytestring       >= 0.10 && < 0.13,         containers       >= 0.5 && < 0.7,-        deepseq          == 1.4.*,+        deepseq          >= 1.4 && < 1.6,         filepath         == 1.4.*,-        ghc-boot         == 9.6.7,-        ghc-heap         == 9.6.7,-        template-haskell == 2.20.*,+        ghc-boot         == 9.8.1,+        ghc-heap         == 9.8.1,+        template-haskell == 2.21.*,         transformers     >= 0.5 && < 0.7      if !os(windows)
libraries/template-haskell/Language/Haskell/TH.hs view
@@ -89,6 +89,7 @@     -- ** Types         Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),         Syntax.Specificity(..),+        Syntax.BndrVis(..),         FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType,      -- ** Documentation
libraries/template-haskell/Language/Haskell/TH/Lib.hs view
@@ -24,7 +24,7 @@         BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ,         FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ,         FamilyResultSigQ, DerivStrategyQ,-        TyVarBndrUnit, TyVarBndrSpec,+        TyVarBndrUnit, TyVarBndrSpec, TyVarBndrVis,      -- ** Constructors lifted to 'Q'     -- *** Literals@@ -44,7 +44,7 @@         appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,         lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,         multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,-        fieldExp, getFieldE, projectionE,+        fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE,     -- **** Ranges     fromE, fromThenE, fromToE, fromThenToE, @@ -77,9 +77,12 @@     varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,      -- *** Type variable binders+    DefaultBndrFlag(defaultBndrFlag),     plainTV, kindedTV,     plainInvisTV, kindedInvisTV,+    plainBndrTV, kindedBndrTV,     specifiedSpec, inferredSpec,+    bndrReq, bndrInvis,      -- *** Roles     nominalR, representationalR, phantomR, inferR,@@ -192,10 +195,10 @@ ------------------------------------------------------------------------------- -- *   Dec -tySynD :: Quote m => Name -> [TyVarBndr ()] -> m Type -> m Dec+tySynD :: Quote m => Name -> [TyVarBndr BndrVis] -> m Type -> m Dec tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con] -> [m DerivClause]+dataD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> [m Con] -> [m DerivClause]       -> m Dec dataD ctxt tc tvs ksig cons derivs =   do@@ -204,7 +207,7 @@     derivs1 <- sequenceA derivs     return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> m Con -> [m DerivClause]+newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Con -> [m DerivClause]          -> m Dec newtypeD ctxt tc tvs ksig con derivs =   do@@ -213,14 +216,14 @@     derivs1 <- sequenceA derivs     return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) -typeDataD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con]+typeDataD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> [m Con]       -> m Dec typeDataD tc tvs ksig cons =   do     cons1 <- sequenceA cons     return (TypeDataD tc tvs ksig cons1) -classD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec+classD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs =   do     decs1 <- sequenceA decs@@ -255,16 +258,16 @@     derivs1 <- sequenceA derivs     return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) -dataFamilyD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> m Dec+dataFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Dec dataFamilyD tc tvs kind     = pure $ DataFamilyD tc tvs kind -openTypeFamilyD :: Quote m => Name -> [TyVarBndr ()] -> FamilyResultSig+openTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig                 -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj     = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) -closedTypeFamilyD :: Quote m => Name -> [TyVarBndr ()] -> FamilyResultSig+closedTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig                   -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns =   do eqns1 <- sequenceA eqns@@ -296,13 +299,28 @@       return $ SigT t' k  ---------------------------------------------------------------------------------- *   Kind+-- *   Type variable binders -plainTV :: Name -> TyVarBndr ()-plainTV n = PlainTV n ()+class DefaultBndrFlag flag where+  defaultBndrFlag :: flag -kindedTV :: Name -> Kind -> TyVarBndr ()-kindedTV n k = KindedTV n () k+instance DefaultBndrFlag () where+  defaultBndrFlag = ()++instance DefaultBndrFlag Specificity where+  defaultBndrFlag = SpecifiedSpec++instance DefaultBndrFlag BndrVis where+  defaultBndrFlag = BndrReq++plainTV :: DefaultBndrFlag flag => Name -> TyVarBndr flag+plainTV n = PlainTV n defaultBndrFlag++kindedTV :: DefaultBndrFlag flag => Name -> Kind -> TyVarBndr flag+kindedTV n k = KindedTV n defaultBndrFlag k++-------------------------------------------------------------------------------+-- *   Kind  starK :: Kind starK = StarT
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs view
@@ -79,6 +79,7 @@  type TyVarBndrUnit       = TyVarBndr () type TyVarBndrSpec       = TyVarBndr Specificity+type TyVarBndrVis        = TyVarBndr BndrVis  ---------------------------------------------------------- -- * Lowercase pattern syntax functions@@ -380,6 +381,12 @@ projectionE :: Quote m => NonEmpty String -> m Exp projectionE xs = pure (ProjectionE xs) +typedSpliceE :: Quote m => m Exp -> m Exp+typedSpliceE = fmap TypedSpliceE++typedBracketE :: Quote m => m Exp -> m Exp+typedBracketE = fmap TypedBracketE+ -- ** 'arithSeqE' Shortcuts fromE :: Quote m => m Exp -> m Exp fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }@@ -412,14 +419,14 @@     ; pure (FunD nm cs1)     } -tySynD :: Quote m => Name -> [m (TyVarBndr ())] -> m Type -> m Dec+tySynD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m Type -> m Dec tySynD tc tvs rhs =   do { tvs1 <- sequenceA tvs      ; rhs1 <- rhs      ; pure (TySynD tc tvs1 rhs1)      } -dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con]+dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con]       -> [m DerivClause] -> m Dec dataD ctxt tc tvs ksig cons derivs =   do@@ -430,7 +437,7 @@     derivs1 <- sequenceA derivs     pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) -newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Con+newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Con          -> [m DerivClause] -> m Dec newtypeD ctxt tc tvs ksig con derivs =   do@@ -441,7 +448,7 @@     derivs1 <- sequenceA derivs     pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) -typeDataD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con]+typeDataD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con]       -> m Dec typeDataD tc tvs ksig cons =   do@@ -450,7 +457,7 @@     cons1   <- sequenceA cons     pure (TypeDataD tc tvs1 ksig1 cons1) -classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec+classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs =   do     tvs1  <- sequenceA tvs@@ -571,20 +578,20 @@     eqn1 <- eqn     pure (TySynInstD eqn1) -dataFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Dec+dataFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Dec dataFamilyD tc tvs kind =   do tvs'  <- sequenceA tvs      kind' <- sequenceA kind      pure $ DataFamilyD tc tvs' kind' -openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig+openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig                 -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj =   do tvs' <- sequenceA tvs      res' <- res      pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) -closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig+closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig                   -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns =   do tvs1    <- sequenceA tvs@@ -879,18 +886,30 @@ plainInvisTV :: Quote m => Name -> Specificity -> m (TyVarBndr Specificity) plainInvisTV n s = pure $ PlainTV n s +plainBndrTV :: Quote m => Name -> BndrVis -> m (TyVarBndr BndrVis)+plainBndrTV n v = pure $ PlainTV n v+ kindedTV :: Quote m => Name -> m Kind -> m (TyVarBndr ()) kindedTV n = fmap (KindedTV n ())  kindedInvisTV :: Quote m => Name -> Specificity -> m Kind -> m (TyVarBndr Specificity) kindedInvisTV n s = fmap (KindedTV n s) +kindedBndrTV :: Quote m => Name -> BndrVis -> m Kind -> m (TyVarBndr BndrVis)+kindedBndrTV n v = fmap (KindedTV n v)+ specifiedSpec :: Specificity specifiedSpec = SpecifiedSpec  inferredSpec :: Specificity inferredSpec = InferredSpec +bndrReq :: BndrVis+bndrReq = BndrReq++bndrInvis :: BndrVis+bndrInvis = BndrInvis+ varK :: Name -> Kind varK = VarT @@ -1091,7 +1110,7 @@     Nothing -> funD nm cs  -- | Variant of 'dataD' that attaches Haddock documentation.-dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)+dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)           -> [(Q Con, Maybe String, [Maybe String])]           -- ^ List of constructors, documentation for the constructor, and           -- documentation for the arguments@@ -1105,7 +1124,7 @@   maybe dec (flip withDecDoc dec) mdoc  -- | Variant of 'newtypeD' that attaches Haddock documentation.-newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)+newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)              -> (Q Con, Maybe String, [Maybe String])              -- ^ The constructor, documentation for the constructor, and              -- documentation for the arguments@@ -1119,7 +1138,7 @@   maybe dec (flip withDecDoc dec) mdoc  -- | Variant of 'typeDataD' that attaches Haddock documentation.-typeDataD_doc :: Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)+typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)           -> [(Q Con, Maybe String, [Maybe String])]           -- ^ List of constructors, documentation for the constructor, and           -- documentation for the arguments@@ -1191,15 +1210,3 @@                     | nm <- get_cons_names c'                     , (i, Just arg_doc) <- zip [0..] arg_docs                 ]-  where-    get_cons_names :: Con -> [Name]-    get_cons_names (NormalC n _) = [n]-    get_cons_names (RecC n _) = [n]-    get_cons_names (InfixC _ n _) = [n]-    get_cons_names (ForallC _ _ cons) = get_cons_names cons-    -- GadtC can have multiple names, e.g-    -- > data Bar a where-    -- >   MkBar1, MkBar2 :: a -> Bar a-    -- Will have one GadtC with [MkBar1, MkBar2] as names-    get_cons_names (GadtC ns _ _) = ns-    get_cons_names (RecGadtC ns _ _) = ns
libraries/template-haskell/Language/Haskell/TH/Ppr.hs view
@@ -232,6 +232,8 @@ pprExp _ (ImplicitParamVarE n) = text ('?' : n) pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f) pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs+pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]"+pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e  pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)@@ -300,27 +302,28 @@ pprLit _ (BytesPrimL {}) = pprString "<binary data>" pprLit i (RationalL rat)   | withoutFactor 2 (withoutFactor 5 $ denominator rat) /= 1-  -- if the denominator has prime factors other than 2 and 5, show as fraction+  -- if the denominator has prime factors other than 2 and 5+  -- or can't be represented as Double, show as fraction   = parensIf (i > noPrec) $     integer (numerator rat) <+> char '/' <+> integer (denominator rat)-  | rat /= 0 && (zeroes < -1 || zeroes > 7),-    let (n, d) = properFraction (rat' / magnitude)-        (rat', zeroes')-          | abs rat < 1 = (10 * rat, zeroes - 1)-          | otherwise = (rat, zeroes)+  | rat /= 0 && (zeroes < -2 || zeroes > 6),+    let (n, d) = properFraction (rat / magnitude)   -- if < 0.01 or >= 100_000_000, use scientific notation   = parensIf (i > noPrec && rat < 0)              (integer n               <> (if d == 0 then empty else char '.' <> decimals (abs d))-              <> char 'e' <> integer zeroes')+              <> char 'e' <> integer zeroes)   | let (n, d) = properFraction rat   = parensIf (i > noPrec && rat < 0)              (integer n <> char '.'               <> if d == 0 then char '0' else decimals (abs d))   where zeroes :: Integer-        zeroes = truncate (logBase 10 (abs (fromRational rat) :: Double)-                           * (1 - epsilon))-        epsilon = 0.0000001+        zeroes = log10 (abs rat)+        log10 :: Rational -> Integer+        log10 x+          | x >= 10 = 1 + log10 (x / 10)+          | x < 1 = -1 + log10 (x * 10)+          | otherwise = 0         magnitude :: Rational         magnitude = 10 ^^ zeroes         withoutFactor :: Integer -> Integer -> Integer@@ -682,22 +685,22 @@                          <+> pprName' Infix c                          <+> pprBangType st2 -    ppr (ForallC ns ctxt (GadtC c sts ty))-        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt+    ppr (ForallC ns ctxt (GadtC cs sts ty))+        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt       <+> pprGadtRHS sts ty -    ppr (ForallC ns ctxt (RecGadtC c vsts ty))-        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt+    ppr (ForallC ns ctxt (RecGadtC cs vsts ty))+        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt       <+> pprRecFields vsts ty      ppr (ForallC ns ctxt con)         = pprForall ns ctxt <+> ppr con -    ppr (GadtC c sts ty)-        = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty+    ppr (GadtC cs sts ty)+        = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty -    ppr (RecGadtC c vsts ty)-        = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty+    ppr (RecGadtC cs vsts ty)+        = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty  instance Ppr PatSynDir where   ppr Unidir        = text "<-"@@ -946,6 +949,14 @@     pprTyVarBndr (PlainTV nm InferredSpec)     = braces (ppr nm)     pprTyVarBndr (KindedTV nm SpecifiedSpec k) = parens (ppr nm <+> dcolon <+> ppr k)     pprTyVarBndr (KindedTV nm InferredSpec  k) = braces (ppr nm <+> dcolon <+> ppr k)++instance PprFlag BndrVis where+    pprTyVarBndr (PlainTV nm vis)    = pprBndrVis vis (ppr nm)+    pprTyVarBndr (KindedTV nm vis k) = pprBndrVis vis (parens (ppr nm <+> dcolon <+> ppr k))++pprBndrVis :: BndrVis -> Doc -> Doc+pprBndrVis BndrReq   d = d+pprBndrVis BndrInvis d = char '@' <> d  instance PprFlag flag => Ppr (TyVarBndr flag) where     ppr bndr = pprTyVarBndr bndr
libraries/template-haskell/Language/Haskell/TH/Syntax.hs view
@@ -3,10 +3,13 @@              RankNTypes, RoleAnnotations, ScopedTypeVariables,              MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,              GADTs, UnboxedTuples, UnboxedSums, TypeOperators,-             Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-}+             Trustworthy, DeriveFunctor, DeriveTraversable,+             BangPatterns, RecordWildCards, ImplicitParams #-}  {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} +{-# LANGUAGE StandaloneKindSignatures #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.Syntax@@ -31,6 +34,7 @@     -- $infix     ) where +import qualified Data.Fixed as Fixed import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO )@@ -54,6 +58,7 @@ import GHC.Generics     ( Generic ) import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..),                           TYPE, RuntimeRep(..) )+import qualified Data.Kind as Kind (Type) import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Ptr          ( Ptr, plusPtr ) import GHC.Lexeme       ( startsVarSym, startsVarId )@@ -66,6 +71,7 @@ import Foreign.C.Types import GHC.Stack + #if __GLASGOW_HASKELL__ >= 901 import GHC.Types ( Levity(..) ) #endif@@ -330,43 +336,14 @@ -- ----------------------------------------------------- +type TExp :: TYPE r -> Kind.Type type role TExp nominal   -- See Note [Role of TExp]-newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp+newtype TExp a = TExp   { unType :: Exp -- ^ Underlying untyped Template Haskell expression   }--- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed--- expressions allow for type-safe splicing via:------   - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if---     that expression has type @a@, then the quotation has type---     @'Q' ('TExp' a)@------   - typed splices inside of typed quotes, written as @$$(...)@ where @...@---     is an arbitrary expression of type @'Q' ('TExp' a)@------ Traditional expression quotes and splices let us construct ill-typed--- expressions:------ >>> fmap ppr $ runQ [| True == $( [| "foo" |] ) |]--- GHC.Types.True GHC.Classes.== "foo"--- >>> GHC.Types.True GHC.Classes.== "foo"--- <interactive> error:---     • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’---     • In the second argument of ‘(==)’, namely ‘"foo"’---       In the expression: True == "foo"---       In an equation for ‘it’: it = True == "foo"------ With typed expressions, the type error occurs when /constructing/ the--- Template Haskell expression:+-- ^ Typed wrapper around an 'Exp'. ----- >>> fmap ppr $ runQ [|| True == $$( [|| "foo" ||] ) ||]--- <interactive> error:---     • Couldn't match type ‘[Char]’ with ‘Bool’---       Expected type: Q (TExp Bool)---         Actual type: Q (TExp [Char])---     • In the Template Haskell quotation [|| "foo" ||]---       In the expression: [|| "foo" ||]---       In the Template Haskell splice $$([|| "foo" ||])+-- This is the typed representation of terms produced by typed quotes. -- -- Representation-polymorphic since /template-haskell-2.16.0.0/. @@ -394,21 +371,56 @@ TExp's argument must have a nominal role, not phantom as would be inferred (#8459).  Consider -  e :: TExp Age-  e = MkAge 3+  e :: Code Q Age+  e = [|| MkAge 3 ||]    foo = $(coerce e) + 4::Int  The splice will evaluate to (MkAge 3) and you can't add that to-4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -}+4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}  -- Code constructor +type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type type role Code representational nominal   -- See Note [Role of TExp]-newtype Code m (a :: TYPE (r :: RuntimeRep)) = Code+newtype Code m a = Code   { examineCode :: m (TExp a) -- ^ Underlying monadic value   }+-- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed+-- expressions allow for type-safe splicing via:+--+--   - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if+--     that expression has type @a@, then the quotation has type+--     @Quote m => Code m a@+--+--   - typed splices inside of typed quotes, written as @$$(...)@ where @...@+--     is an arbitrary expression of type @Quote m => Code m a@+--+-- Traditional expression quotes and splices let us construct ill-typed+-- expressions:+--+-- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |])+-- GHC.Types.True GHC.Classes.== "foo"+-- >>> GHC.Types.True GHC.Classes.== "foo"+-- <interactive> error:+--     • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’+--     • In the second argument of ‘(==)’, namely ‘"foo"’+--       In the expression: True == "foo"+--       In an equation for ‘it’: it = True == "foo"+--+-- With typed expressions, the type error occurs when /constructing/ the+-- Template Haskell expression:+--+-- >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||])+-- <interactive> error:+--     • Couldn't match type ‘[Char]’ with ‘Bool’+--       Expected type: Code Q Bool+--         Actual type: Code Q [Char]+--     • In the Template Haskell quotation [|| "foo" ||]+--       In the expression: [|| "foo" ||]+--       In the Template Haskell splice $$([|| "foo" ||]) + -- | Unsafely convert an untyped code representation into a typed code -- representation. unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .@@ -957,7 +969,7 @@ -- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or -- @[|| ... ||]@) but not at the top level. As an example: ----- > add1 :: Int -> Q (TExp Int)+-- > add1 :: Int -> Code Q Int -- > add1 x = [|| x + 1 ||] -- -- Template Haskell has no way of knowing what value @x@ will take on at@@ -965,7 +977,7 @@ -- -- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@ -- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.--- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@.+-- It is additionally expected that @'lift' x ≡ 'unTypeCode' ('liftTyped' x)@. -- -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@ -- GHC language extension:@@ -1056,6 +1068,14 @@   liftTyped x = unsafeCodeCoerce (lift x)   lift x = return (LitE (IntegerL (fromIntegral x))) +instance Lift (Fixed.Fixed a) where+  liftTyped x = unsafeCodeCoerce (lift x)+  lift (Fixed.MkFixed x) = do+    ex <- lift x+    return (ConE mkFixedName `AppE` ex)+    where+      mkFixedName = mkNameG DataName "base" "Data.Fixed" "MkFixed"+ instance Integral a => Lift (Ratio a) where   liftTyped x = unsafeCodeCoerce (lift x)   lift x = return (LitE (RationalL (toRational x)))@@ -1125,10 +1145,6 @@       ptr :: ForeignPtr Word8       ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb)) ---- We can't use a TH quote in this module because we're in the template-haskell--- package, so we conconct this quite defensive solution to make the correct name--- which will work if the package name or module name changes in future. addrToByteArrayName :: Name addrToByteArrayName = helper   where@@ -1374,6 +1390,7 @@ oneName, manyName :: Name oneName  = mkNameG DataName "ghc-prim" "GHC.Types" "One" manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many"+ ----------------------------------------------------- -- --              Generic Lift implementations@@ -1488,8 +1505,9 @@           -- See #10796.           varOrConE s =             case nameSpace s of-                 Just VarName  -> return (VarE s)-                 Just DataName -> return (ConE s)+                 Just VarName      -> return (VarE s)+                 Just (FldName {}) -> return (VarE s)+                 Just DataName     -> return (ConE s)                  _ -> error $ "Can't construct an expression from name "                            ++ showName s           appE x y = do { a <- x; b <- y; return (AppE a b)}@@ -1665,6 +1683,14 @@                | DataName       -- ^ Data constructors                | TcClsName      -- ^ Type constructors and classes; Haskell has them                                 -- in the same name space for now.+               | FldName+                 { fldParent :: !String+                   -- ^ 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.+                 }                deriving( Eq, Ord, Show, Data, Generic )  -- | @Uniq@ is used by GHC to distinguish names from each other.@@ -1824,6 +1850,13 @@ mkNameG_tc = mkNameG TcClsName mkNameG_d  = mkNameG DataName +mkNameG_fld :: String -- ^ package+            -> String -- ^ module+            -> String -- ^ parent (first constructor of parent type)+            -> String -- ^ field name+            -> Name+mkNameG_fld pkg modu con occ = mkNameG (FldName con) pkg modu occ+ data NameIs = Alone | Applied | Infix  showName :: Name -> String@@ -1847,11 +1880,11 @@         -- We may well want to distinguish them in the end.         -- Ditto NameU and NameL         nms = case nm of-                    Name occ NameS         -> occString occ-                    Name occ (NameQ m)     -> modString m ++ "." ++ occString occ-                    Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ-                    Name occ (NameU u)     -> occString occ ++ "_" ++ show u-                    Name occ (NameL u)     -> occString occ ++ "_" ++ show u+          Name occ NameS          -> occString occ+          Name occ (NameQ m)      -> modString m ++ "." ++ occString occ+          Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ+          Name occ (NameU u)      -> occString occ ++ "_" ++ show u+          Name occ (NameL u)      -> occString occ ++ "_" ++ show u          pnam = classify nms @@ -2359,6 +2392,8 @@   | ImplicitParamVarE String           -- ^ @{ ?x }@ ( Implicit parameter )   | GetFieldE Exp String               -- ^ @{ exp.field }@ ( Overloaded Record Dot )   | ProjectionE (NonEmpty String)      -- ^ @(.x)@ or @(.x.y)@ (Record projections)+  | TypedBracketE Exp                  -- ^ @[|| e ||]@+  | TypedSpliceE Exp                   -- ^ @$$e@   deriving( Show, Eq, Ord, Data, Generic )  type FieldExp = (Name,Exp)@@ -2392,22 +2427,22 @@ data Dec   = FunD Name [Clause]            -- ^ @{ f p1 p2 = b where decs }@   | ValD Pat Body [Dec]           -- ^ @{ p = b where decs }@-  | DataD Cxt Name [TyVarBndr ()]+  | DataD Cxt Name [TyVarBndr BndrVis]           (Maybe Kind)            -- Kind signature (allowed only for GADTs)           [Con] [DerivClause]                                   -- ^ @{ data Cxt x => T x = A x | B (T x)                                   --       deriving (Z,W)                                   --       deriving stock Eq }@-  | NewtypeD Cxt Name [TyVarBndr ()]+  | NewtypeD Cxt Name [TyVarBndr BndrVis]              (Maybe Kind)         -- Kind signature              Con [DerivClause]    -- ^ @{ newtype Cxt x => T x = A (B x)                                   --       deriving (Z,W Q)                                   --       deriving stock Eq }@-  | TypeDataD Name [TyVarBndr ()]+  | TypeDataD Name [TyVarBndr BndrVis]           (Maybe Kind)            -- Kind signature (allowed only for GADTs)           [Con]                   -- ^ @{ type data T x = A x | B (T x) }@-  | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@-  | ClassD Cxt Name [TyVarBndr ()]+  | TySynD Name [TyVarBndr BndrVis] Type -- ^ @{ type T x = (x,x) }@+  | ClassD Cxt Name [TyVarBndr BndrVis]          [FunDep] [Dec]           -- ^ @{ class Eq a => Ord a where ds }@   | InstanceD (Maybe Overlap) Cxt Type [Dec]                                   -- ^ @{ instance {\-\# OVERLAPS \#-\}@@ -2424,7 +2459,7 @@   | PragmaD Pragma                -- ^ @{ {\-\# INLINE [1] foo \#-\} }@    -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD')-  | DataFamilyD Name [TyVarBndr ()]+  | DataFamilyD Name [TyVarBndr BndrVis]                (Maybe Kind)          -- ^ @{ data family T a b c :: * }@ @@ -2548,7 +2583,7 @@ -- @TypeFamilyHead@ is defined to be the elements of the declaration -- between @type family@ and @where@. data TypeFamilyHead =-  TypeFamilyHead Name [TyVarBndr ()] FamilyResultSig (Maybe InjectivityAnn)+  TypeFamilyHead Name [TyVarBndr BndrVis] FamilyResultSig (Maybe InjectivityAnn)   deriving( Show, Eq, Ord, Data, Generic )  -- | One equation of a type family instance or closed type family. The@@ -2658,7 +2693,7 @@                        | DecidedUnpack -- ^ Field inferred to be unpacked.         deriving (Show, Eq, Ord, Data, Generic) --- | A single data constructor.+-- | A data constructor. -- -- The constructors for 'Con' can roughly be divided up into two categories: -- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and@@ -2691,16 +2726,36 @@ -- Multiplicity annotations for data types are currently not supported -- in Template Haskell (i.e. all fields represented by Template Haskell -- will be linear).-data Con = NormalC Name [BangType]       -- ^ @C Int a@-         | RecC Name [VarBangType]       -- ^ @C { v :: Int, w :: a }@-         | InfixC BangType Name BangType -- ^ @Int :+ a@-         | ForallC [TyVarBndr Specificity] Cxt Con -- ^ @forall a. Eq a => C [a]@-         | GadtC [Name] [BangType]-                 Type                    -- See Note [GADT return type]-                                         -- ^ @C :: a -> b -> T b Int@-         | RecGadtC [Name] [VarBangType]-                    Type                 -- See Note [GADT return type]-                                         -- ^ @C :: { v :: Int } -> T b Int@+data Con =+  -- | @C Int a@+    NormalC Name [BangType]++  -- | @C { v :: Int, w :: a }@+  | RecC Name [VarBangType]++  -- | @Int :+ a@+  | InfixC BangType Name BangType++  -- | @forall a. Eq a => C [a]@+  | ForallC [TyVarBndr Specificity] Cxt Con++  -- @C :: a -> b -> T b Int@+  | GadtC [Name]+            -- ^ The list of constructors, corresponding to the GADT constructor+            -- syntax @C1, C2 :: a -> T b@.+            --+            -- Invariant: the list must be non-empty.+          [BangType] -- ^ The constructor arguments+          Type -- ^ See Note [GADT return type]++  -- | @C :: { v :: Int } -> T b Int@+  | RecGadtC [Name]+             -- ^ The list of constructors, corresponding to the GADT record+             -- constructor syntax @C1, C2 :: { fld :: a } -> T b@.+             --+             -- Invariant: the list must be non-empty.+             [VarBangType] -- ^ The constructor arguments+             Type -- ^ See Note [GADT return type]         deriving (Show, Eq, Ord, Data, Generic)  -- Note [GADT return type]@@ -2804,10 +2859,20 @@                  | InferredSpec           -- ^ @{a}@       deriving( Show, Eq, Ord, Data, Generic ) +-- | The @flag@ type parameter is instantiated to one of the following types:+--+--   * 'Specificity' (examples: 'ForallC', 'ForallT')+--   * 'BndrVis' (examples: 'DataD', 'ClassD', etc.)+--   * '()', a catch-all type for other forms of binders, including 'ForallVisT', 'DataInstD', 'RuleP', and 'TyVarSig'+-- data TyVarBndr flag = PlainTV  Name flag      -- ^ @a@                     | KindedTV Name flag Kind -- ^ @(a :: k)@-      deriving( Show, Eq, Ord, Data, Generic, Functor )+      deriving( Show, Eq, Ord, Data, Generic, Functor, Foldable, Traversable ) +data BndrVis = BndrReq                    -- ^ @a@+             | BndrInvis                  -- ^ @\@a@+      deriving( Show, Eq, Ord, Data, Generic )+ -- | Type family result signature data FamilyResultSig = NoSig              -- ^ no signature                      | KindSig  Kind      -- ^ @k@@@ -2897,3 +2962,15 @@ thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _  = o1++get_cons_names :: Con -> [Name]+get_cons_names (NormalC n _)     = [n]+get_cons_names (RecC n _)        = [n]+get_cons_names (InfixC _ n _)    = [n]+get_cons_names (ForallC _ _ con) = get_cons_names con+-- GadtC can have multiple names, e.g+-- > data Bar a where+-- >   MkBar1, MkBar2 :: a -> Bar a+-- Will have one GadtC with [MkBar1, MkBar2] as names+get_cons_names (GadtC ns _ _)    = ns+get_cons_names (RecGadtC ns _ _) = ns
libraries/template-haskell/template-haskell.cabal view
@@ -3,7 +3,7 @@ -- template-haskell.cabal.  name:           template-haskell-version:        2.20.0.0+version:        2.21.0.0 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -55,8 +55,8 @@         Language.Haskell.TH.Lib.Map      build-depends:-        base        >= 4.11 && < 4.19,-        ghc-boot-th == 9.6.7,+        base        >= 4.11 && < 4.20,+        ghc-boot-th == 9.8.1,         ghc-prim,         pretty      == 1.1.*