ghc-lib-parser 9.12.2.20250421 → 9.12.3.20251228

raw patch · 60 files changed

+2437/−1840 lines, 60 filesdep +hpcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hpc

API changes (from Hackage documentation)

Files

• compiler/GHC/Builtin/Names.hs +5/−5
• compiler/GHC/Builtin/Types.hs +36/−37
• compiler/GHC/Cmm/CLabel.hs +14/−10
• compiler/GHC/Cmm/MachOp.hs +15/−0
• compiler/GHC/Cmm/Reg.hs +2/−2
• compiler/GHC/Core/DataCon.hs +3/−0
• compiler/GHC/Core/InstEnv.hs +131/−40
• compiler/GHC/Core/Predicate.hs +56/−19
• compiler/GHC/Core/TyCo/Rep.hs +7/−5
• compiler/GHC/Core/TyCo/Tidy.hs +6/−4
• compiler/GHC/Core/TyCon.hs +1/−0
• compiler/GHC/Core/Utils.hs +5/−2
• compiler/GHC/Driver/DynFlags.hs +0/−1
• compiler/GHC/Driver/Errors/Ppr.hs +2/−2
• compiler/GHC/Driver/Flags.hs +3/−1
• compiler/GHC/Driver/Session.hs +1/−0
• compiler/GHC/Hs/Expr.hs +1/−1
• compiler/GHC/Hs/ImpExp.hs +0/−1
• compiler/GHC/Iface/Syntax.hs +1/−1
• compiler/GHC/Parser/Errors/Types.hs +1/−0
• compiler/GHC/Parser/HaddockLex.x +1/−0
• compiler/GHC/Parser/Lexer.x +30/−125
• compiler/GHC/Parser/Lexer/Interface.hs +124/−0
• compiler/GHC/Parser/Lexer/String.x +96/−0
• compiler/GHC/Parser/String.hs +34/−3
• compiler/GHC/Tc/Errors/Ppr.hs +34/−30
• compiler/GHC/Tc/Errors/Types.hs +30/−8
• compiler/GHC/Tc/Solver/Types.hs +1/−1
• compiler/GHC/Tc/Types/TH.hs +1/−1
• compiler/GHC/Tc/Utils/TcType.hs +5/−3
• compiler/GHC/Types/DefaultEnv.hs +21/−14
• compiler/GHC/Types/Hint.hs +2/−1
• compiler/GHC/Types/Id/Make.hs +69/−21
• compiler/GHC/Types/Name/Ppr.hs +2/−1
• compiler/GHC/Types/Tickish.hs +4/−2
• compiler/GHC/Types/Var.hs +1/−0
• compiler/GHC/Unit/External.hs +4/−1
• compiler/GHC/Unit/Module/ModDetails.hs +1/−1
• compiler/cbits/genSym.c +13/−3
• compiler/ghc.cabal +8/−6
• ghc-lib-parser.cabal +21/−15
• ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +2/−2
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +150/−0
• ghc/ghc-bin.cabal +4/−4
• libraries/ghc-boot-th-internal/GHC/Internal/TH/Lib/Map.hs +0/−111
• libraries/ghc-boot-th-internal/GHC/Internal/TH/Ppr.hs +0/−1096
• libraries/ghc-boot-th-internal/GHC/Internal/TH/PprLib.hs +0/−226
• libraries/ghc-boot-th/GHC/Boot/TH/Lib/Map.hs +111/−0
• libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs +1096/−0
• libraries/ghc-boot-th/GHC/Boot/TH/PprLib.hs +226/−0
• libraries/ghc-boot-th/GHC/Boot/TH/Syntax.hs +6/−0
• libraries/ghc-boot-th/ghc-boot-th.cabal +13/−11
• libraries/ghc-boot/ghc-boot.cabal +3/−3
• libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc +9/−3
• libraries/ghc-heap/ghc-heap.cabal +2/−2
• libraries/ghci/GHCi/Message.hs +6/−2
• libraries/ghci/GHCi/TH/Binary.hs +1/−1
• libraries/ghci/ghci.cabal +7/−7
• libraries/template-haskell/template-haskell.cabal +5/−1

@@ -256,7 +256,7 @@         typeRepIdName,         mkTrTypeName,         mkTrConName,-        mkTrAppName,+        mkTrAppCheckedName,         mkTrFunName,         typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,         trGhcPrimModuleName,@@ -1369,7 +1369,7 @@   , someTypeRepDataConName   , mkTrTypeName   , mkTrConName-  , mkTrAppName+  , mkTrAppCheckedName   , mkTrFunName   , typeRepIdName   , typeNatTypeRepName@@ -1384,7 +1384,7 @@ typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey-mkTrAppName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey+mkTrAppCheckedName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey typeNatTypeRepName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey@@ -2507,7 +2507,7 @@ mkTyConKey   , mkTrTypeKey   , mkTrConKey-  , mkTrAppKey+  , mkTrAppCheckedKey   , mkTrFunKey   , typeNatTypeRepKey   , typeSymbolTypeRepKey@@ -2517,7 +2517,7 @@ mkTyConKey            = mkPreludeMiscIdUnique 503 mkTrTypeKey           = mkPreludeMiscIdUnique 504 mkTrConKey            = mkPreludeMiscIdUnique 505-mkTrAppKey            = mkPreludeMiscIdUnique 506+mkTrAppCheckedKey     = mkPreludeMiscIdUnique 506 typeNatTypeRepKey     = mkPreludeMiscIdUnique 507 typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508 typeCharTypeRepKey    = mkPreludeMiscIdUnique 509

@@ -78,6 +78,7 @@         promotedTupleDataCon,         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,         soloTyCon,+        soloDataConName,         pairTyCon, mkPromotedPairTy, isPromotedPairType,         unboxedUnitTy,         unboxedUnitTyCon, unboxedUnitDataCon,@@ -895,7 +896,6 @@       ":"    -> Just consDataConName        -- function tycon-      "FUN"  -> Just fUNTyConName       "->"  -> Just unrestrictedFunTyConName        -- tuple data/tycon@@ -1054,40 +1054,36 @@     isCTupleOcc_maybe  mod occ <|>     isSumTyOcc_maybe   mod occ -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName--- No need to cache these, the caching is done in mk_tuple-mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr ns ar)-mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ns ar)+mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax)+mkTupleOcc ns b ar = (mkOccName ns str, built_in)+  where (str, built_in) = mkTupleStr' ns b ar  mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)  mkTupleStr :: Boxity -> NameSpace -> Arity -> String-mkTupleStr Boxed   = mkBoxedTupleStr-mkTupleStr Unboxed = mkUnboxedTupleStr--mkBoxedTupleStr :: NameSpace -> Arity -> String-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 ""-+mkTupleStr b ns ar = str+  where (str, _) = mkTupleStr' ns b ar -mkUnboxedTupleStr :: NameSpace -> Arity -> String-mkUnboxedTupleStr ns 0-  | isDataConNameSpace ns = "(##)"-  | otherwise             = "Unit#"-mkUnboxedTupleStr ns 1-  | isDataConNameSpace ns = "MkSolo#"  -- See Note [One-tuples]-  | otherwise             = "Solo#"-mkUnboxedTupleStr ns ar-  | isDataConNameSpace ns = "(#" ++ commas ar ++ "#)"-  | otherwise             = "Tuple" ++ show ar ++ "#"+mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax)+mkTupleStr' ns Boxed 0+  | isDataConNameSpace ns = ("()", BuiltInSyntax)+  | otherwise             = ("Unit", UserSyntax)+mkTupleStr' ns Boxed 1+  | isDataConNameSpace ns = ("MkSolo", UserSyntax)  -- See Note [One-tuples]+  | otherwise             = ("Solo",   UserSyntax)+mkTupleStr' ns Boxed ar+  | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ showInt ar "", UserSyntax)+mkTupleStr' ns Unboxed 0+  | isDataConNameSpace ns = ("(##)",  BuiltInSyntax)+  | otherwise             = ("Unit#", UserSyntax)+mkTupleStr' ns Unboxed 1+  | isDataConNameSpace ns = ("MkSolo#", UserSyntax) -- See Note [One-tuples]+  | otherwise             = ("Solo#",   UserSyntax)+mkTupleStr' ns Unboxed ar+  | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ show ar ++ "#", UserSyntax)  mkConstraintTupleStr :: Arity -> String mkConstraintTupleStr 0 = "CUnit"@@ -1243,10 +1239,10 @@      boxity  = Boxed     modu    = gHC_INTERNAL_TUPLE-    tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq-                         (ATyCon tycon) UserSyntax-    dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq-                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity     tc_uniq = mkTupleTyConUnique   boxity arity     dc_uniq = mkTupleDataConUnique boxity arity @@ -1277,10 +1273,10 @@      boxity  = Unboxed     modu    = gHC_TYPES-    tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq-                         (ATyCon tycon) UserSyntax-    dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq-                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity     tc_uniq = mkTupleTyConUnique   boxity arity     dc_uniq = mkTupleDataConUnique boxity arity @@ -1343,6 +1339,9 @@  soloTyConName :: Name soloTyConName = tyConName soloTyCon++soloDataConName :: Name+soloDataConName = tupleDataConName Boxed 1  pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2

@@ -102,7 +102,7 @@         needsCDecl,         maybeLocalBlockLabel,         externallyVisibleCLabel,-        isMathFun,+        isLibcFun,         isCFunctionLabel,         isGcPtrLabel,         labelDynamic,@@ -1028,7 +1028,7 @@         -- For other labels we inline one into the HC file directly.         | otherwise                     = True -needsCDecl l@(ForeignLabel{})           = not (isMathFun l)+needsCDecl l@(ForeignLabel{})           = not (isLibcFun l) needsCDecl (CC_Label _)                 = True needsCDecl (CCS_Label _)                = True needsCDecl (IPE_Label {})               = True@@ -1055,15 +1055,19 @@   -- | Check whether a label corresponds to a C function that has---      a prototype in a system header somewhere, or is built-in---      to the C compiler. For these labels we avoid generating our---      own C prototypes.-isMathFun :: CLabel -> Bool-isMathFun (ForeignLabel fs _ _)       = fs `elementOfUniqSet` math_funs-isMathFun _ = False+-- a prototype in a system header somewhere, or is built-in+-- to the C compiler. For these labels we avoid generating our+-- own C prototypes.+isLibcFun :: CLabel -> Bool+isLibcFun (ForeignLabel fs _ _)  = fs `elementOfUniqSet` libc_funs+isLibcFun _ = False -math_funs :: UniqSet FastString-math_funs = mkUniqSet [+libc_funs :: UniqSet FastString+libc_funs = mkUniqSet [+        ---------------------+        -- Math functions+        ---------------------+         -- _ISOC99_SOURCE         (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),         (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),

@@ -7,6 +7,7 @@     , pprMachOp, isCommutableMachOp, isAssociativeMachOp     , isComparisonMachOp, maybeIntComparison, machOpResultType     , machOpArgReps, maybeInvertComparison, isFloatComparison+    , isCommutableCallishMachOp      -- MachOp builders     , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot@@ -845,3 +846,17 @@   MO_Memmove align -> Just align   MO_Memcmp  align -> Just align   _                -> Nothing++isCommutableCallishMachOp :: CallishMachOp -> Bool+isCommutableCallishMachOp op =+  case op of+    MO_x64_Add  -> True+    MO_x64_Mul  -> True+    MO_x64_Eq   -> True+    MO_x64_Ne   -> True+    MO_x64_And  -> True+    MO_x64_Or   -> True+    MO_x64_Xor  -> True+    MO_S_Mul2 _ -> True+    MO_U_Mul2 _ -> True+    _ -> False

@@ -98,8 +98,8 @@ pprReg :: CmmReg -> SDoc pprReg r    = case r of-        CmmLocal  local                     -> pprLocalReg  local-        CmmGlobal (GlobalRegUse global _ty) -> pprGlobalReg global+        CmmLocal  local                   -> pprLocalReg  local+        CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global  cmmRegType :: CmmReg -> CmmType cmmRegType (CmmLocal  reg) = localRegType reg

@@ -1033,6 +1033,9 @@     gunfold _ _  = error "gunfold"     dataTypeOf _ = mkNoRepType "DataCon" +instance Outputable HsSrcBang where+    ppr (HsSrcBang _source_text bang) = ppr bang+ instance Outputable HsBang where     ppr (HsBang prag mark) = ppr prag <+> ppr mark 

@@ -599,7 +599,7 @@ manual section on "overlapping instances". At risk of duplication, here are the rules.  If the rules change, change this text and the user manual simultaneously.  The link may be this:-http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap+https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/instances.html#instance-overlap  The willingness to be overlapped or incoherent is a property of the instance declaration itself, controlled by its `OverlapMode`, as follows@@ -627,14 +627,22 @@  (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.+      the search fails unless -XIncoherentInstances is enabled. See+      Note [Instance and Given overlap] in GHC.Tc.Solver.Dict.  This is+      implemented by the first guard in matchClassInst. -(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/.+(IL1) Find `all_matches` and `all_unifs` in `lookupInstEnv`:+      - all_matches: all instances `I` that *match* the target constraint (that+        is, the target constraint is a substitution instance of `I`). These+        instance declarations are the /candidates/.+      - all_unifs: all non-incoherent instances that *unify with but do not match*+        the target constraint. These are not candidates, but might match later if+        the target constraint is furhter instantiated. See+        `data PotentialUnifiers` for more precise details. -(IL2) If there are no candidates, the search fails.+(IL2) If there are no candidates, the search fails+      (lookupInstEnv returns no final_matches). The PotentialUnifiers are returned+      by lookupInstEnv for use in error message generation (mkDictErr).  (IL3) Eliminate any candidate `IX` for which there is another candidate `IY` such       that both of the following hold:@@ -644,30 +652,40 @@         "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.)-      This is done by `pruneOverlappingMatches` -(IL4) If all the remaining candidates are *incoherent*, the search succeeds,-      returning an arbitrary surviving candidate.+      In addition, provided there is at least one candidate, eliminate any other+      candidates that are *incoherent*. (In particular, if all remaining candidates+      are incoherent, all except an arbitrarily chosen one will be eliminated.) -      If any coherent or non-canonical incoherent unifiers were discarded,-      return NoUnifiers EvNonCanonical; if only canonical incoherent unifiers-      were discarded, return NoUnifiers EvCanonical+      This is implemented by `pruneOverlappedMatches`, producing final_matches in+      lookupInstEnv.  See Note [Instance overlap and guards] and+      Note [Incoherent instances]. -(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".+(IL4) If exactly one *incoherent* candidate remains, the search succeeds.+      (By the previous step, there cannot be more than one incoherent candidate+      remaining.) -(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.+      In this case, lookupInstEnv returns the successful match, and it returns+      NoUnifiers as the final_unifs, which amounts to skipping the following+      steps. -      If any are *coherent* (not incoherent) return them-      as PotentialUnifiers.+(IL5) If more than one candidate remains, the search fails. (We have already+      eliminated the incoherent candidates, and we have no way to select+      between non-incoherent candidates.) -      If all are *incoherent* (OverlapFlag = Incoherent or NonCanonical)-      return (NoUnifiers nc), where nc is EvNonCanonical if any of the discarded-      unifiers are NonCanonical.+(IL6) Otherwise there is exactly one candidate remaining. The all_unifs+      computed at step (IL1) are returned from lookupInstEnv as final_unifs. +      If there are no potential unifiers, the search succeeds (in matchInstEnv).+      If there is at least one (non-incoherent) potential unifier, matchInstEnv+      returns a NotSure result and refrains from committing to the instance.++      Incoherent instances are not returned as part of the potential unifiers. This+      affects error messages: they will not be listed as "potentially matching instances"+      in an "Overlapping instances" or "Ambiguous type variable" error.+      See also Note [Recording coherence information in `PotentialUnifiers`].++ Notice that these rules are not influenced by flag settings in the client module, where the instances are *used*. These rules make it possible for a library author to design a library that relies on@@ -894,8 +912,8 @@  To avoid this incoherence breaking the specialiser, -* We label as "non-canonical" the dictionary constructed by a (potentially)-  incoherent use of an ClsInst whose `OverlapFlag` is `NonCanonical`.+* We label as "non-canonical" any dictionary constructed by a (potentially)+  incoherent use of an ClsInst.  * We do not specialise a function if there is a non-canonical   dictionary in the /transistive dependencies/ of its dictionary@@ -922,7 +940,9 @@ Here are the moving parts:  * GHC.Core.InstEnv.lookupInstEnv tells if any incoherent unifiers were discarded-  in step (IL6) of the instance lookup.+  in step (IL4) or (IL6) of the instance lookup: see+  Note [Recording coherence information in `PotentialUnifiers`] and+  Note [Canonicity for incoherent matches].  * That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence   transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary.@@ -933,6 +953,47 @@   See Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds.    See also Note [nospecId magic] in GHC.Types.Id.Make.+++Note [Canonicity for incoherent matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the selected instance is INCOHERENT at step (IL4) of+Note [Rules for instance lookup], we ignore all unifiers,+whether or not they are marked with INCOHERENT pragmas.+This is implemented by returning NoUnifiers in final_unifs.+NoUnifiers takes an argument indicating whether the match was canonical+as described in Note [Coherence and specialisation: overview] and+Note [Recording coherence information in `PotentialUnifiers`].++To determine whether an incoherent match was canonical, we look *only*+at the OverlapFlag of the instance being matched. For example:++  class C a+  instance {-# INCOHERENT #-} C a -- (1)+  instance C Int   -- (2)++  [W] C tau++Here we match instance (1) and discard instance (2). If (1) is Incoherent+(under -fspecialise-incoherents), it is important that we treat the match+as EvCanonical so that we do not block specialisation (see #25883).++What about the following situation:++  instance {-# INCOHERENT #-} C a    -- (1), in a module with -fspecialise-incoherents (Incoherent)+  instance {-# INCOHERENT #-} C Int  -- (2), in a module with -fno-specialise-incoherents (NonCanonical)++  [W] C tau++Again we match instance (1) and discard instance (2). It is not obvious+whether Incoherent or NonCanonical should "win" here, but it seems more+consistent with the previous example to look only at the flag on instance (1).++What about if the only instance that can match is marked as NonCanonical?+In this case are no unifiers at all, so all_unifs = NoUnifiers EvCanonical.+It is not obvious what -fno-specialise-incoherents should do here, but+currently it returns NoUnifiers EvCanonical.+ -}  type DFunInstType = Maybe Type@@ -1073,8 +1134,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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+don't care (see step (IL6) in Note [Rules for instance lookup]).+But if we have potentially unifying coherent instance, we report these `OneOrMoreUnifiers` so that `matchInstEnv` can go down the `NotSure` route. @@ -1084,6 +1145,21 @@ overview] for why we care at all). So when the set of potential unifiers is empty, we record in `NoUnifiers` if the one solution is `Canonical`.++For example, suppose we have:++  class C x y+  instance C a Bool                   -- (1)+  instance {-# INCOHERENT #-} C Int a -- (2)++  [W] C x Bool++Here instance (1) matches the Wanted, and since instance (2) is INCOHERENT+we want to succeed with the match rather than getting stick at step (IL6).+But if -fno-specialise-incoherents was enabled for (2), the specialiser is+not permitted to specialise this dictionary later, so lookupInstEnv reports+the PotentialUnifiers as NoUnifiers EvNonCanonical.+ -}  instance Outputable CanonicalEvidence where@@ -1104,15 +1180,24 @@ getCoherentUnifiers NoUnifiers{} = [] getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls +-- | Are there no *coherent* unifiers? nullUnifiers :: PotentialUnifiers -> Bool nullUnifiers NoUnifiers{} = True nullUnifiers _ = False -lookupInstEnv' :: InstEnv          -- InstEnv to look in-               -> VisibleOrphanModules   -- But filter against this-               -> Class -> [Type]  -- What we are looking for-               -> ([InstMatch],    -- Successful matches-                   PotentialUnifiers)      -- These don't match but do unify+-- | Are there any unifiers, ignoring those marked Incoherent (but including any+-- marked NonCanonical)?+someUnifiers :: PotentialUnifiers -> Bool+someUnifiers (NoUnifiers EvCanonical) = False+someUnifiers _ = True+++instEnvMatchesAndUnifiers+  :: InstEnv          -- InstEnv to look in+  -> VisibleOrphanModules   -- But filter against this+  -> Class -> [Type]  -- What we are looking for+  -> ([InstMatch],    -- Successful matches+      PotentialUnifiers)      -- These don't match but do unify                                    -- (no incoherent ones in here) -- The second component of the result pair happens when we look up --      Foo [a]@@ -1124,7 +1209,7 @@ -- but Foo [Int] is a unifier.  This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' (InstEnv rm) vis_mods cls tys+instEnvMatchesAndUnifiers (InstEnv rm) vis_mods cls tys   = (foldr check_match [] rough_matches, check_unifiers rough_unifiers)   where     (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm@@ -1207,10 +1292,13 @@               tys   = (final_matches, final_unifs, unsafe_overlapped)   where-    (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys-    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys+    -- (IL1): Find all instances that match the target constraint+    (home_matches, home_unifs) = instEnvMatchesAndUnifiers home_ie vis_mods cls tys+    (pkg_matches,  pkg_unifs)  = instEnvMatchesAndUnifiers pkg_ie  vis_mods cls tys     all_matches = home_matches <> pkg_matches     all_unifs   = home_unifs <> pkg_unifs++    -- (IL3): Eliminate candidates that are overlapped or incoherent     final_matches = pruneOverlappedMatches all_matches         -- Even if the unifs is non-empty (an error situation)         -- we still prune the matches, so that the error message isn't@@ -1228,10 +1316,13 @@                     (m:ms) | isIncoherent (fst m)                            -- Incoherent match, so discard all unifiers, but                            -- keep track of dropping coherent or non-canonical ones+                           -- if the match is non-canonical.+                           -- See Note [Canonicity for incoherent matches]                            -> assertPpr (null ms) (ppr final_matches) $-                              case all_unifs of-                                OneOrMoreUnifiers{} -> NoUnifiers EvNonCanonical-                                NoUnifiers{}        -> all_unifs+                              NoUnifiers $+                                 if isNonCanonical (fst m) && someUnifiers all_unifs+                                    then EvNonCanonical+                                    else EvCanonical                     _      -> all_unifs      -- Note [Safe Haskell isSafeOverlap]

@@ -27,7 +27,7 @@   -- Implicit parameters   isIPLikePred, mentionsIP, isIPTyCon, isIPClass,   isCallStackTy, isCallStackPred, isCallStackPredTy,-  isExceptionContextPred,+  isExceptionContextPred, isExceptionContextTy,   isIPPred_maybe,    -- Evidence variables@@ -39,7 +39,6 @@  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@@ -318,7 +317,7 @@   | otherwise   = Nothing --- | Is a type a 'CallStack'?+-- | Is a type an 'ExceptionContext'? isExceptionContextTy :: Type -> Bool isExceptionContextTy ty   | Just tc <- tyConAppTyCon_maybe ty@@ -364,31 +363,38 @@ 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+isIPLikePred pred =+  mentions_ip_pred initIPRecTc (const True) (const True) 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.+mentionsIP :: (Type -> Bool) -- ^ predicate on the string+           -> (Type -> Bool) -- ^ predicate on the type+           -> Class+           -> [Type] -> Bool+-- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:+--+--    - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@+--      are both @True@,+--    - or any superclass of @cls tys@ has this property.+-- -- See Note [Local implicit parameters]-mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys+mentionsIP = mentions_ip initIPRecTc -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'+mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool+mentions_ip rec_clss str_cond ty_cond cls tys+  | Just (str_ty, ty) <- isIPPred_maybe cls tys+  = str_cond str_ty && ty_cond ty   | otherwise-  = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys)+  = or [ mentions_ip_pred rec_clss str_cond ty_cond (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++mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool+mentions_ip_pred rec_clss str_cond ty_cond ty   | Just (cls, tys) <- getClassPredTys_maybe ty   , let tc = classTyCon cls   , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss                       else checkRecTc rec_clss tc-  = mentions_ip rec_clss' mb_str_ty cls tys+  = mentions_ip rec_clss' str_cond ty_cond cls tys   | otherwise   = False -- Includes things like (D []) where D is           -- a Constraint-ranged family; #7785@@ -455,7 +461,38 @@ * The superclass hunt stops when it encounters the same class again,   but in principle we could have the same class, differently instantiated,   and the second time it could have an implicit parameter-I'm going to treat these as problems for another day. They are all exotic.  -}+I'm going to treat these as problems for another day. They are all exotic.++Note [Using typesAreApart when calling mentionsIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We call 'mentionsIP' in two situations:++  (1) to check that a predicate does not contain any implicit parameters+      IP str ty, for a fixed literal str and any type ty,+  (2) to check that a predicate does not contain any HasCallStack or+      HasExceptionContext constraints.++In both of these cases, we want to be sure, so we should be conservative:++  For (1), the predicate might contain an implicit parameter IP Str a, where+  Str is a type family such as:++    type family MyStr where MyStr = "abc"++  To safeguard against this (niche) situation, instead of doing a simple+  type equality check, we use 'typesAreApart'. This allows us to recognise+  that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'.++  For (2), we similarly might have++    type family MyCallStack where MyCallStack = CallStack++  Again, here we use 'typesAreApart'. This allows us to see that++    (?foo :: MyCallStack)++  is indeed a CallStack constraint, hidden under a type family.+-}  {- ********************************************************************* *                                                                      *

@@ -155,11 +155,13 @@    | ForAllTy  -- See Note [ForAllTy]         {-# UNPACK #-} !ForAllTyBinder-        Type            -- ^ A Π type.-             -- See Note [Why ForAllTy can quantify over a coercion variable]-             -- INVARIANT: If the binder is a coercion variable, it must-             --            be mentioned in the Type.-             --            See Note [Unused coercion variable in ForAllTy]+           -- ForAllTyBinder: see GHC.Types.Var+           --    Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]+        Type+           -- INVARIANT: If the binder is a coercion variable, it must+           --            be mentioned in the Type.+           --            See Note [Unused coercion variable in ForAllTy]+           -- See Note [Why ForAllTy can quantify over a coercion variable]    | FunTy      -- ^ FUN m t1 t2   Very common, so an important special case                 -- See Note [Function types]

@@ -336,16 +336,18 @@     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2     go (ForAllCo tv visL visR h co)       = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)-                               where (envp, tvp) = tidyVarBndr env tv+      where (envp, tvp) = tidyVarBndr env tv             -- the case above duplicates a bit of work in tidying h and the kind             -- of tv. But the alternative is to use coercionKind, which seems worse.     go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2     go (CoVarCo cv)          = CoVarCo $! go_cv cv     go (HoleCo h)            = HoleCo $! go_hole h     go (AxiomCo ax cos)      = AxiomCo ax $ strictMap go cos-    go co@(UnivCo { uco_lty  = t1, uco_rty = t2 })-                             = co { uco_lty = tidyType env t1, uco_rty = tidyType env t2 }-                               -- Don't bother to tidy the uco_deps field+    go (UnivCo prov role t1 t2 cos)+                             = ((UnivCo prov role+                                $! tidyType env t1)+                                $! tidyType env t2)+                                $! strictMap go cos     go (SymCo co)            = SymCo $! go co     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2     go (SelCo d co)          = SelCo d $! go co

@@ -2695,6 +2695,7 @@ tyConStupidTheta tc@(TyCon { tyConDetails = details })   | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid   | PrimTyCon {} <- details                         = []+  | PromotedDataCon {} <- details                   = []   | otherwise = pprPanic "tyConStupidTheta" (ppr tc)  -- | Extract the 'TyVar's bound by a vanilla type synonym

@@ -307,7 +307,6 @@   -- Some ticks (cost-centres) can be split in two, with the   -- non-counting part having laxer placement properties.   canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t-   -- mkTick' handles floating of ticks *into* the expression.   -- In this function, `top` is applied after adding the tick, and `rest` before.   -- This will result in applications that look like (top $ Tick t $ rest expr).@@ -318,6 +317,10 @@           -> CoreExpr               -- current expression           -> CoreExpr   mkTick' top rest expr = case expr of+    -- Float ticks into unsafe coerce the same way we would do with a cast.+    Case scrut bndr ty alts@[Alt ac abs _rhs]+      | Just rhs <- isUnsafeEqualityCase scrut bndr alts+      -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs      -- Cost centre ticks should never be reordered relative to each     -- other. Therefore we can stop whenever two collide.@@ -1253,7 +1256,7 @@ Ticks are only trivial if they are pure annotations. If we treat "tick<n> x" as trivial, it will be inlined inside lambdas and the entry count will be skewed, for example.  Furthermore "scc<n> x" will-turn into just "x" in mkTick.+turn into just "x" in mkTick. At least if `x` is not a function.  Note [Empty case is trivial] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1194,7 +1194,6 @@      ++ validHoleFitDefaults -     where platform = sTargetPlatform settings  -- | These are the default settings for the display and sorting of valid hole

@@ -276,7 +276,7 @@             ++ llvmVersionStr supportedLlvmVersionLowerBound             ++ " and "             ++ llvmVersionStr supportedLlvmVersionUpperBound-            ++ ") and reinstall GHC to make -fllvm work")+            ++ ") and reinstall GHC to ensure -fllvm works")    diagnosticReason = \case     DriverUnknownMessage m@@ -347,7 +347,7 @@     DriverInstantiationNodeInDependencyGeneration {}       -> ErrorWithoutFlag     DriverNoConfiguredLLVMToolchain-      -> ErrorWithoutFlag+      -> WarningWithoutFlag    diagnosticHints = \case     DriverUnknownMessage m

@@ -339,7 +339,7 @@     , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)     , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures) -    -- See Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind+    -- See (NVP3) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind     , (LangExt.LinearTypes, turnOn, LangExt.MonoLocalBinds)   ] @@ -647,6 +647,7 @@    | Opt_CmmElimCommonBlocks    | Opt_CmmControlFlow    | Opt_AsmShortcutting+   | Opt_InterModuleFarJumps    | Opt_OmitYields    | Opt_FunToThunk               -- deprecated    | Opt_DictsStrict                     -- be strict in argument dictionaries@@ -896,6 +897,7 @@    , Opt_CmmSink    , Opt_CmmElimCommonBlocks    , Opt_AsmShortcutting+   , Opt_InterModuleFarJumps    , Opt_FunToThunk    , Opt_DmdTxDictSel    , Opt_Loopification

@@ -2454,6 +2454,7 @@   flagSpec "gen-manifest"                     Opt_GenManifest,   flagSpec "ghci-history"                     Opt_GhciHistory,   flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,+  flagSpec "inter-module-far-jumps"               Opt_InterModuleFarJumps,   flagSpec "validate-ide-info"                Opt_ValidateHie,   flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,   flagGhciSpec "no-it"                        Opt_NoIt,

@@ -67,7 +67,7 @@ import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)  import GHCi.RemoteTypes ( ForeignRef )-import qualified GHC.Internal.TH.Syntax as TH (Q)+import qualified GHC.Boot.TH.Syntax as TH (Q)  -- libraries: import Data.Data hiding (Fixity(..))

@@ -259,7 +259,6 @@ ieNames (IEThingAbs  _ (L _ n) _)      = [ieWrappedName n] ieNames (IEThingAll  _ (L _ n) _)      = [ieWrappedName n] ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns--- NB the above case does not include names of field selectors ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = [] ieNames (IEDoc            {})     = []

@@ -324,7 +324,7 @@ -- See Note [Named default declarations] in GHC.Tc.Gen.Default -- | Exported named defaults data IfaceDefault-  = IfaceDefault { ifDefaultCls  :: IfaceTyCon,            -- Defaulted class+  = IfaceDefault { ifDefaultCls  :: IfExtName,            -- Defaulted class                    ifDefaultTys  :: [IfaceType],          -- List of defaults                    ifDefaultWarn :: Maybe IfaceWarningTxt } 

@@ -594,6 +594,7 @@    | LexUnterminatedComment -- ^ Unterminated `{-'    | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma    | LexUnterminatedQQ      -- ^ Unterminated quasiquotation+   deriving (Show,Eq,Ord)  -- | Errors from the Cmm parser data CmmParserError

@@ -8,6 +8,7 @@ import GHC.Data.FastString import GHC.Hs.Doc import GHC.Parser.Lexer+import GHC.Parser.Lexer.Interface (adjustChar) import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Types.SourceText

@@ -41,6 +41,7 @@ -- Alex "Haskell code fragment top"  {+{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -78,7 +79,6 @@    commentToAnnotation,    HdkComment(..),    warnopt,-   adjustChar,    addPsMessage   ) where @@ -132,6 +132,8 @@ import GHC.Parser.Errors.Basic import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr ()+import GHC.Parser.Lexer.Interface+import qualified GHC.Parser.Lexer.String as Lexer.String import GHC.Parser.String } @@ -143,7 +145,7 @@ $unispace    = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl          = [\n\r\f] $space       = [\ $unispace]-$whitechar   = [$nl \v $space]+$whitechar   = [$nl \t \v $space] $white_no_nl = $whitechar # \n -- TODO #8424 $tab         = \t @@ -246,7 +248,7 @@ -- Alex "Rules"  -- everywhere: skip whitespace-$white_no_nl+ ;+($white_no_nl # \t)+ ; $tab          { warnTab }  -- Everywhere: deal with nested comments.  We explicitly rule out@@ -622,13 +624,6 @@   \" @stringchar*    $unigraphic / { isSmartQuote } { smart_quote_error } } -<string_multi_content> {-  -- Parse as much of the multiline string as possible, except for quotes-  @stringchar* ($nl ([\  $tab] | @gap)* @stringchar*)* { tok_string_multi_content }-  -- Allow bare quotes if it's not a triple quote-  (\" | \"\") / ([\n .] # \") { tok_string_multi_content }-}- <0> {   \'\' { token ITtyQuote } @@ -2171,11 +2166,23 @@     src = SourceText $ lexemeToFastString buf len     endsInHash = currentChar (offsetBytes (len - 1) buf) == '#' --- | Ideally, we would define this completely with Alex syntax, like normal strings.--- Instead, this is defined as a hybrid solution by manually invoking lex states, which--- we're doing for two reasons:---   1. The multiline string should all be one lexical token, not multiple---   2. We need to allow bare quotes, which can't be done with one regex+{- Note [Lexing multiline strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ideally, we would lex multiline strings completely with Alex syntax, like+normal strings. However, we can't because:++    1. The multiline string should all be one lexical token, not multiple+    2. We need to allow bare quotes, which can't be done with one regex++Instead, we'll lex them with a hybrid solution in tok_string_multi by manually+invoking lex states. This allows us to get the performance of native Alex+syntax as much as possible, and just gluing the pieces together outside of+Alex.++Implemented in string_multi_content in GHC/Parser/Lexer/String.x+-}++-- | See Note [Lexing multiline strings] tok_string_multi :: Action tok_string_multi startSpan startBuf _len _buf2 = do   -- advance to the end of the multiline string@@ -2201,17 +2208,14 @@   pure $ L span $ ITstringMulti src (mkFastString s)   where     goContent i0 =-      case alexScan i0 string_multi_content of-        AlexToken i1 len _+      case Lexer.String.alexScan i0 Lexer.String.string_multi_content of+        Lexer.String.AlexToken i1 len _           | Just i2 <- lexDelim i1 -> pure (i1, i2)           | isEOF i1 -> checkSmartQuotes >> setInput i1 >> lexError LexError-          -- is the next token a tab character?-          -- need this explicitly because there's a global rule matching $tab-          | Just ('\t', _) <- alexGetChar' i1 -> setInput i1 >> lexError LexError           -- Can happen if no patterns match, e.g. an unterminated gap           | len == 0  -> setInput i1 >> lexError LexError           | otherwise -> goContent i1-        AlexSkip i1 _ -> goContent i1+        Lexer.String.AlexSkip i1 _ -> goContent i1         _ -> setInput i0 >> lexError LexError      lexDelim =@@ -2235,11 +2239,6 @@         Just (c, loc) -> throwSmartQuoteError c loc         Nothing -> pure () --- | Dummy action that should never be called. Should only be used in lex states--- that are manually lexed in tok_string_multi.-tok_string_multi_content :: Action-tok_string_multi_content = panic "tok_string_multi_content unexpectedly invoked"- lex_chars :: (String, String) -> PsSpan -> StringBuffer -> Int -> P String lex_chars (startDelim, endDelim) span buf len =   either (throwStringLexError i0) pure $@@ -2593,105 +2592,6 @@ getLastLoc :: P PsSpan getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc -data AlexInput = AI !PsLoc !StringBuffer deriving (Show)--{--Note [Unicode in Alex]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Although newer versions of Alex support unicode, this grammar is processed with-the old style '--latin1' behaviour. This means that when implementing the-functions--    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)-    alexInputPrevChar :: AlexInput -> Char--which Alex uses to take apart our 'AlexInput', we must--  * return a latin1 character in the 'Word8' that 'alexGetByte' expects-  * return a latin1 character in 'alexInputPrevChar'.--We handle this in 'adjustChar' by squishing entire classes of unicode-characters into single bytes.--}--{-# INLINE adjustChar #-}-adjustChar :: Char -> Word8-adjustChar c = adj_c-  where non_graphic     = 0x00-        upper           = 0x01-        lower           = 0x02-        digit           = 0x03-        symbol          = 0x04-        space           = 0x05-        other_graphic   = 0x06-        uniidchar       = 0x07--        adj_c-          | c <= '\x07' = non_graphic-          | c <= '\x7f' = fromIntegral (ord c)-          -- Alex doesn't handle Unicode, so when Unicode-          -- character is encountered we output these values-          -- with the actual character value hidden in the state.-          | otherwise =-                -- NB: The logic behind these definitions is also reflected-                -- in "GHC.Utils.Lexeme"-                -- Any changes here should likely be reflected there.--                case generalCategory c of-                  UppercaseLetter       -> upper-                  LowercaseLetter       -> lower-                  TitlecaseLetter       -> upper-                  ModifierLetter        -> uniidchar -- see #10196-                  OtherLetter           -> lower -- see #1103-                  NonSpacingMark        -> uniidchar -- see #7650-                  SpacingCombiningMark  -> other_graphic-                  EnclosingMark         -> other_graphic-                  DecimalNumber         -> digit-                  LetterNumber          -> digit-                  OtherNumber           -> digit -- see #4373-                  ConnectorPunctuation  -> symbol-                  DashPunctuation       -> symbol-                  OpenPunctuation       -> other_graphic-                  ClosePunctuation      -> other_graphic-                  InitialQuote          -> other_graphic-                  FinalQuote            -> other_graphic-                  OtherPunctuation      -> symbol-                  MathSymbol            -> symbol-                  CurrencySymbol        -> symbol-                  ModifierSymbol        -> symbol-                  OtherSymbol           -> symbol-                  Space                 -> space-                  _other                -> non_graphic---- Getting the previous 'Char' isn't enough here - we need to convert it into--- the same format that 'alexGetByte' would have produced.------ See Note [Unicode in Alex] and #13986.-alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc))-  where pc = prevChar buf '\n'--unsafeChr :: Int -> Char-unsafeChr (I# c) = GHC.Exts.C# (GHC.Exts.chr# c)---- backwards compatibility for Alex 2.x-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar inp = case alexGetByte inp of-                    Nothing    -> Nothing-                    Just (b,i) -> c `seq` Just (c,i)-                       where c = unsafeChr $ fromIntegral b---- See Note [Unicode in Alex]-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)-alexGetByte (AI loc s)-  | atEnd s   = Nothing-  | otherwise = byte `seq` loc' `seq` s' `seq`-                --trace (show (ord c)) $-                Just (byte, (AI loc' s'))-  where (c,s') = nextChar s-        loc'   = advancePsLoc loc c-        byte   = adjustChar c- {-# INLINE alexGetChar' #-} -- This version does not squash unicode characters, it is used when -- lexing strings.@@ -3471,10 +3371,15 @@ topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b +#ifdef MIN_TOOL_VERSION_alex+#if !MIN_TOOL_VERSION_alex(3,5,2) -- If the generated alexScan/alexScanUser functions are called multiple times -- in this file, alexScanUser gets broken out into a separate function and -- increases memory usage. Make sure GHC inlines this function and optimizes it.+-- https://github.com/haskell/alex/pull/262 +#endif+#endif  lexToken :: P (PsLocated Token) lexToken = do

@@ -0,0 +1,124 @@+{-# LANGUAGE MagicHash #-}++{- |+This module defines the types and functions necessary for an Alex-generated+lexer.++https://haskell-alex.readthedocs.io/en/latest/api.html#+-}+module GHC.Parser.Lexer.Interface (+  AlexInput (..),+  alexGetByte,+  alexInputPrevChar,++  -- * Helpers+  alexGetChar,+  adjustChar,+) where++import GHC.Prelude++import Data.Char (GeneralCategory (..), generalCategory, ord)+import Data.Word (Word8)+import GHC.Data.StringBuffer (StringBuffer, atEnd, nextChar, prevChar)+import GHC.Exts+import GHC.Types.SrcLoc (PsLoc, advancePsLoc)++data AlexInput = AI !PsLoc !StringBuffer deriving (Show)++-- See Note [Unicode in Alex]+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (AI loc s)+  | atEnd s   = Nothing+  | otherwise = byte `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (byte, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advancePsLoc loc c+        byte   = adjustChar c++-- Getting the previous 'Char' isn't enough here - we need to convert it into+-- the same format that 'alexGetByte' would have produced.+--+-- See Note [Unicode in Alex] and #13986.+alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc))+  where pc = prevChar buf '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = unsafeChr $ fromIntegral b++unsafeChr :: Int -> Char+unsafeChr (I# c) = GHC.Exts.C# (GHC.Exts.chr# c)++{-+Note [Unicode in Alex]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Although newer versions of Alex support unicode, this grammar is processed with+the old style '--latin1' behaviour. This means that when implementing the+functions++    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)+    alexInputPrevChar :: AlexInput -> Char++which Alex uses to take apart our 'AlexInput', we must++  * return a latin1 character in the 'Word8' that 'alexGetByte' expects+  * return a latin1 character in 'alexInputPrevChar'.++We handle this in 'adjustChar' by squishing entire classes of unicode+characters into single bytes.+-}++{-# INLINE adjustChar #-}+adjustChar :: Char -> Word8+adjustChar c = adj_c+  where non_graphic     = 0x00+        upper           = 0x01+        lower           = 0x02+        digit           = 0x03+        symbol          = 0x04+        space           = 0x05+        other_graphic   = 0x06+        uniidchar       = 0x07++        adj_c+          | c <= '\x07' = non_graphic+          | c <= '\x7f' = fromIntegral (ord c)+          -- Alex doesn't handle Unicode, so when Unicode+          -- character is encountered we output these values+          -- with the actual character value hidden in the state.+          | otherwise =+                -- NB: The logic behind these definitions is also reflected+                -- in "GHC.Utils.Lexeme"+                -- Any changes here should likely be reflected there.++                case generalCategory c of+                  UppercaseLetter       -> upper+                  LowercaseLetter       -> lower+                  TitlecaseLetter       -> upper+                  ModifierLetter        -> uniidchar -- see #10196+                  OtherLetter           -> lower -- see #1103+                  NonSpacingMark        -> uniidchar -- see #7650+                  SpacingCombiningMark  -> other_graphic+                  EnclosingMark         -> other_graphic+                  DecimalNumber         -> digit+                  LetterNumber          -> digit+                  OtherNumber           -> digit -- see #4373+                  ConnectorPunctuation  -> symbol+                  DashPunctuation       -> symbol+                  OpenPunctuation       -> other_graphic+                  ClosePunctuation      -> other_graphic+                  InitialQuote          -> other_graphic+                  FinalQuote            -> other_graphic+                  OtherPunctuation      -> symbol+                  MathSymbol            -> symbol+                  CurrencySymbol        -> symbol+                  ModifierSymbol        -> symbol+                  OtherSymbol           -> symbol+                  Space                 -> space+                  _other                -> non_graphic

@@ -0,0 +1,96 @@+{+{- |+This module defines lex states for strings.++This needs to be separate from the normal lexer because the normal lexer+automatically includes rules like skipping whitespace or lexing comments,+which we don't want in these contexts.+-}+module GHC.Parser.Lexer.String (+  AlexReturn (..),+  alexScan,+  string_multi_content,+) where++import GHC.Prelude++import GHC.Parser.Lexer.Interface+import GHC.Utils.Panic (panic)+}++-- -----------------------------------------------------------------------------+-- Alex "Character set macros"+-- Copied from GHC/Parser/Lexer.x++$unispace    = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$nl          = [\n\r\f]+$space       = [\ $unispace]+$whitechar   = [$nl \t \v $space]+$tab         = \t++$ascdigit  = 0-9+$unidigit  = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$decdigit  = $ascdigit -- exactly $ascdigit, no more no less.+$digit     = [$ascdigit $unidigit]++$special   = [\(\)\,\;\[\]\`\{\}]+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]+$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']++$unilarge  = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$asclarge  = [A-Z]+$large     = [$asclarge $unilarge]++$unismall  = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$ascsmall  = [a-z]+$small     = [$ascsmall $unismall \_]++$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$idchar    = [$small $large $digit $uniidchar \']++$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$graphic   = [$small $large $symbol $digit $idchar $special $unigraphic \"\']+$charesc   = [a b f n r t v \\ \" \' \&]++$octit     = 0-7+$hexit     = [$decdigit A-F a-f]++-- -----------------------------------------------------------------------------+-- Alex "Regular expression macros"+-- Copied from GHC/Parser/Lexer.x++@numspc       = _*                   -- numeric spacer (#14473)+@decimal      = $decdigit(@numspc $decdigit)*+@octal        = $octit(@numspc $octit)*+@hexadecimal  = $hexit(@numspc $hexit)*+@gap = \\ $whitechar+ \\+@cntrl = $asclarge | \@ | \[ | \\ | \] | \^ | \_+@ascii = \^ @cntrl | "NUL" | "SOH" | "STX" | "ETX" | "EOT" | "ENQ" | "ACK"+       | "BEL" | "BS" | "HT" | "LF" | "VT" | "FF" | "CR" | "SO" | "SI" | "DLE"+       | "DC1" | "DC2" | "DC3" | "DC4" | "NAK" | "SYN" | "ETB" | "CAN"+       | "EM" | "SUB" | "ESC" | "FS" | "GS" | "RS" | "US" | "SP" | "DEL"+@escape     = \\ ( $charesc      | @ascii | @decimal | o @octal | x @hexadecimal )+@stringchar = ($graphic # [\\ \"]) | $space | @escape     | @gap++:-++-- Define an empty rule so it compiles; callers should always explicitly specify a startcode+<0> () ;++-- See Note [Lexing multiline strings]+<string_multi_content> {+  -- Parse as much of the multiline string as possible, except for quotes+  @stringchar* ($nl ([\  $tab] | @gap)* @stringchar*)* { string_multi_content_action }+  -- Allow bare quotes if it's not a triple quote+  (\" | \"\") / ([\n .] # \") { string_multi_content_action }+}++-- -----------------------------------------------------------------------------+-- Haskell actions+{+-- | Dummy action that should never be called. Should only be used in lex states+-- that are manually lexed in tok_string_multi.+string_multi_content_action :: a+string_multi_content_action = panic "string_multi_content_action unexpectedly invoked"+}

@@ -36,6 +36,7 @@  type BufPos = Int data StringLexError = StringLexError LexErr BufPos+  deriving (Show, Eq)  lexString :: Int -> StringBuffer -> Either StringLexError String lexString = lexStringWith processChars processChars@@ -122,19 +123,49 @@ -- ----------------------------------------------------------------------------- -- Lexing phases +-- | Collapse all string gaps in the given input.+--+-- Iterates through the input in `go` until we encounter a backslash. The+-- @stringchar Alex regex only allows backslashes in two places: escape codes+-- and string gaps.+--+--   * If the next character is a space, it has to be the start of a string gap+--     AND it must end, since the @gap Alex regex will only match if it ends.+--     Collapse the gap and continue the main iteration loop.+--+--   * Otherwise, this is an escape code. If it's an escape code, there are+--     ONLY three possibilities (see the @escape Alex regex):+--       1. The escape code is "\\"+--       2. The escape code is "\^\"+--       3. The escape code does not have a backslash, other than the initial+--          backslash+--+--     In the first two possibilities, just skip them and continue the main+--     iteration loop ("skip" as in "keep in the list as-is"). In the last one,+--     we can just skip the backslash, then continue the main iteration loop.+--     the rest of the escape code will be skipped as normal characters in the+--     string; no need to fully parse a proper escape code. collapseGaps :: HasChar c => [c] -> [c] collapseGaps = go   where     go = \case-      c1@(Char '\\') : c2@(Char c) : cs-        | is_space c -> go $ dropGap cs-        | otherwise  -> c1 : c2 : go cs+      -- Match the start of a string gap + drop gap+      -- #25784: string gaps are semantically equivalent to "\&"+      c1@(Char '\\') : Char c : cs+        | is_space c -> c1 : setChar '&' c1 : go (dropGap cs)+      -- Match all possible escape characters that include a backslash+      c1@(Char '\\') : c2@(Char '\\') : cs+        -> c1 : c2 : go cs+      c1@(Char '\\') : c2@(Char '^') : c3@(Char '\\') : cs+        -> c1 : c2 : c3 : go cs+      -- Otherwise, just keep looping       c : cs -> c : go cs       [] -> []      dropGap = \case       Char '\\' : cs -> cs       _ : cs -> dropGap cs+      -- Unreachable since gaps must end; see docstring       [] -> panic "gap unexpectedly ended"  resolveEscapes :: HasChar c => [c] -> Either (c, LexErr) [c]

@@ -36,12 +36,12 @@  import GHC.Prelude -import qualified GHC.Internal.TH.Syntax as TH--- In stage1: import "ghc-boot-th-next" qualified GHC.Internal.TH.Syntax as TH--- In stage2: import "ghc-boot-th"      qualified GHC.Internal.TH.Syntax as TH---            which resolves to+import qualified GHC.Boot.TH.Syntax as TH+-- In stage1: import "ghc-boot-th-next" qualified GHC.Boot.TH.Syntax as TH+-- In stage2: import "ghc-boot-th"      qualified GHC.Boot.TH.Syntax as TH+--            which is a rexport of --            import "ghc-internal"     qualified GHC.Internal.TH.Syntax as TH-import qualified GHC.Internal.TH.Ppr as TH+import qualified GHC.Boot.TH.Ppr as TH  import GHC.Builtin.Names import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple, pretendNameIsInScope )@@ -61,7 +61,7 @@ import GHC.Core.InstEnv import GHC.Core.TyCo.Rep (Type(..)) import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,-                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType)+                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll) import GHC.Core.PatSyn ( patSynName, pprPatSynType ) import GHC.Core.Predicate import GHC.Core.Type@@ -576,7 +576,7 @@     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))+              2 (foldr1 (\a b -> a <+> text "or" <+> b) (NE.map (quotes. ppr) deflt_clss))     TcRnPatSynBundledWithNonDataCon       -> mkSimpleDecorated $            text "Pattern synonyms can be bundled only with datatypes."@@ -1353,24 +1353,27 @@       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"-          LamAlt LamCase                         -> text "\\case expression"-          ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"-          ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"-          ArrowMatchCtxt ArrowCaseAlt            -> text "case command"-          _                                      -> text "(unexpected)"-                                                    <+> pprMatchContextNoun ctxt--        message = case ctxt of-          LamAlt LamCases -> lcases_msg <+> text "expression"-          ArrowMatchCtxt (ArrowLamAlt 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"+    TcRnEmptyCase ctxt reason -> mkSimpleDecorated $+      case reason of+        EmptyCaseWithoutFlag ->+          text "Empty list of alternatives in" <+> pp_ctxt+        EmptyCaseDisallowedCtxt ->+          text "Empty list of alternatives is not allowed in" <+> pp_ctxt+        EmptyCaseForall tvb ->+          vcat [ text "Empty list of alternatives in" <+> pp_ctxt+               , hang (text "checked against a forall-type:")+                      2 (pprForAll [tvb] <+> text "...")+               ]+        where+          pp_ctxt = case ctxt of+            CaseAlt                                -> text "case expression"+            LamAlt LamCase                         -> text "\\case expression"+            LamAlt LamCases                        -> text "\\cases expression"+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"+            ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> text "\\cases command"+            ArrowMatchCtxt ArrowCaseAlt            -> text "case command"+            ctxt                                   -> text "(unexpected)" <+> pprMatchContextNoun ctxt     TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $       text "accepting non-standard pattern guards" $$       nest 4 (interpp'SP guards)@@ -3071,10 +3074,11 @@       -> noHints     TcRnOrphanCompletePragma{}       -> noHints-    TcRnEmptyCase ctxt -> case ctxt of-      LamAlt LamCases -> noHints -- cases syntax doesn't support empty case.-      ArrowMatchCtxt (ArrowLamAlt LamCases) -> noHints-      _ -> [suggestExtension LangExt.EmptyCase]+    TcRnEmptyCase _ reason ->+      case reason of+        EmptyCaseWithoutFlag{}    -> [suggestExtension LangExt.EmptyCase]+        EmptyCaseDisallowedCtxt{} -> noHints+        EmptyCaseForall{}         -> noHints     TcRnNonStdGuards{}       -> [suggestExtension LangExt.PatternGuards]     TcRnDuplicateSigDecl{}@@ -5919,7 +5923,7 @@     doc_monad =       "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" -suggestDefaultDeclaration :: TyCon -> [Type] -> [[Type]] -> [GhcHint]+suggestDefaultDeclaration :: Class-> [Type] -> [[Type]] -> [GhcHint] suggestDefaultDeclaration cls prefix seqs =   [SuggestDefaultDeclaration cls $ supersequence (prefix : seqs)]   where

@@ -104,6 +104,7 @@   , DisabledClassExtension(..)   , TyFamsDisabledReason(..)   , TypeApplication(..)+  , BadEmptyCaseReason(..)   , HsTypeOrSigType(..)   , HsTyVarBndrExistentialFlag(..)   , TySynCycleTyCons@@ -218,7 +219,8 @@ 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.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder)+ import GHC.Driver.Backend (Backend)  import GHC.Utils.Outputable@@ -233,7 +235,7 @@  import qualified Data.List.NonEmpty as NE import           Data.Typeable (Typeable)-import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Syntax as TH import Data.Map.Strict (Map)  import GHC.Generics ( Generic )@@ -1470,7 +1472,7 @@       Text cases: module/mod58   -}-  TcRnMultipleDefaultDeclarations :: TyCon -> [LDefaultDecl GhcRn] -> TcRnMessage+  TcRnMultipleDefaultDeclarations :: Class -> [LDefaultDecl GhcRn] -> TcRnMessage    {-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports       more than one default declaration for the same class, and they are not all@@ -1480,7 +1482,7 @@       Test cases: default/Import07.hs   -}-  TcRnWarnClashingDefaultImports :: TyCon -- ^ class+  TcRnWarnClashingDefaultImports :: Class                                  -> Maybe [Type] -- ^ locally declared defaults                                  -> NE.NonEmpty ClassDefaults -- ^ imported defaults                                  -> TcRnMessage@@ -1494,7 +1496,7 @@       Test cases: typecheck/should_fail/T11974b   -}-  TcRnBadDefaultType :: Type -> [TyCon] -> TcRnMessage+  TcRnBadDefaultType :: Type -> NE.NonEmpty Class -> TcRnMessage    {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's       export list bundles a pattern synonym with a type that is not a proper@@ -3069,13 +3071,27 @@       a case expression with an empty list of alternatives without       enabling the EmptyCase extension. -     Example(s):+     Example for EmptyCaseWithoutFlag: -       case () of+       {-# LANGUAGE NoEmptyCase #-}+       f :: Void -> a+       f = \case {}    -- extension not enabled +     Example for EmptyCaseDisallowedCtxt:++       f = \cases {}   -- multi-case requires n>0 alternatives++     Example for EmptyCaseForall:++       f :: forall (xs :: Type) -> ()+       f = \case {}    -- can't match on a type argument+      Test cases: rename/should_fail/RnEmptyCaseFail+                 typecheck/should_fail/T25004   -}-  TcRnEmptyCase :: HsMatchContextRn -> TcRnMessage+  TcRnEmptyCase :: !HsMatchContextRn+                -> !BadEmptyCaseReason+                -> TcRnMessage    {-| TcRnNonStdGuards is a warning thrown when a user uses       non-standard guards (e.g. patterns in guards) without@@ -6179,6 +6195,12 @@   = TypeApplication !(HsType GhcPs) !TypeOrKind   | TypeApplicationInPattern !(HsConPatTyArg GhcPs)   deriving Generic++-- | Why was the empty case rejected?+data BadEmptyCaseReason+  = EmptyCaseWithoutFlag+  | EmptyCaseDisallowedCtxt+  | EmptyCaseForall ForAllTyBinder  -- | Either `HsType p` or `HsSigType p`. --

@@ -167,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.Dict.canDictNC, by+* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by   pushing the call-site info on the stack, and changing the CtOrigin   to record that has been done.    Bind:  s1 = pushCallStack <site-info> s2

@@ -13,7 +13,7 @@   ) where  import GHCi.RemoteTypes-import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Syntax as TH import GHC.Tc.Types.Evidence import GHC.Utils.Outputable import GHC.Prelude

@@ -1490,8 +1490,10 @@   = split n_req ty ty []   where     split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs-      | isVisibleForAllTyFlag argf, n_req > 0           = split (n_req - 1) ty ty (b:bs)-      | otherwise                                       = split n_req       ty ty (b:bs)+      | isVisibleForAllTyFlag argf, n_req > 0  -- Split off a visible forall+      = split (n_req - 1) ty ty (b:bs)+      | isInvisibleForAllTyFlag argf           -- Split off an invisible forall,+      = split n_req       ty ty (b:bs)         -- even if n_req=0, i.e. the trailing ones     split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs     split n_req orig_ty _ty bs                          = (n_req, reverse bs, orig_ty) @@ -1975,7 +1977,7 @@ --     forall a. blah --     Eq a => blah --     ?x::Int => blah--- But not+-- But NOT --     forall a -> blah isSigmaTy (ForAllTy (Bndr _ af) _)     = isInvisibleForAllTyFlag af isSigmaTy (FunTy { ft_af = af })       = isInvisibleFunArg af

@@ -11,16 +11,16 @@    , filterDefaultEnv    , defaultList    , plusDefaultEnv+   , mkDefaultEnv    ) where +import GHC.Core.Class (Class (className)) import GHC.Prelude-import GHC.Core.TyCon (TyCon(tyConName))-import GHC.Core.TyCon.Env (TyConEnv, emptyTyConEnv, isEmptyTyConEnv, mkTyConEnvWith, unitTyConEnv,-                           filterTyConEnv, nonDetTyConEnvElts, plusTyConEnv) import GHC.Hs.Extension (GhcRn) import GHC.Tc.Utils.TcType (Type) import GHC.Types.Name (Name, nameUnique, stableNameCmp)+import GHC.Types.Name.Env import GHC.Types.Unique.FM (lookupUFM_Directly) import GHC.Unit.Module.Warnings (WarningTxt) import GHC.Unit.Types (Module)@@ -31,11 +31,11 @@ import Data.Function (on)  -- See Note [Named default declarations] in GHC.Tc.Gen.Default--- | Default environment mapping class @TyCon@s to their default type lists-type DefaultEnv = TyConEnv ClassDefaults+-- | Default environment mapping class name @Name@ to their default type lists+type DefaultEnv = NameEnv ClassDefaults  data ClassDefaults-  = ClassDefaults { cd_class   :: !TyCon  -- ^ always a class constructor+  = ClassDefaults { cd_class   :: Class -- ^ The class whose defaults are being defined                   , cd_types   :: [Type]                   , cd_module :: Maybe Module                     -- ^ @Nothing@ for built-in,@@ -47,29 +47,36 @@   deriving Data  instance Outputable ClassDefaults where-  ppr ClassDefaults {cd_class = cls, cd_types = tys} = text "default" <+> ppr cls <+> parens (interpp'SP tys)+  ppr ClassDefaults {cd_class = cls, cd_types = tys} = text "default" <+> ppr cls+        <+> parens (interpp'SP tys)  emptyDefaultEnv :: DefaultEnv-emptyDefaultEnv = emptyTyConEnv+emptyDefaultEnv = emptyNameEnv  isEmptyDefaultEnv :: DefaultEnv -> Bool-isEmptyDefaultEnv = isEmptyTyConEnv+isEmptyDefaultEnv = isEmptyNameEnv  unitDefaultEnv :: ClassDefaults -> DefaultEnv-unitDefaultEnv d = unitTyConEnv (cd_class d) d+unitDefaultEnv d = unitNameEnv (className $ cd_class d) d  defaultEnv :: [ClassDefaults] -> DefaultEnv-defaultEnv = mkTyConEnvWith cd_class+defaultEnv = mkNameEnvWith (className . cd_class)  defaultList :: DefaultEnv -> [ClassDefaults]-defaultList = sortBy (stableNameCmp `on` (tyConName . cd_class)) . nonDetTyConEnvElts+defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts               -- sortBy recovers determinism  lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults lookupDefaultEnv env = lookupUFM_Directly env . nameUnique  filterDefaultEnv :: (ClassDefaults -> Bool) -> DefaultEnv -> DefaultEnv-filterDefaultEnv = filterTyConEnv+filterDefaultEnv = filterNameEnv  plusDefaultEnv :: DefaultEnv -> DefaultEnv -> DefaultEnv-plusDefaultEnv = plusTyConEnv+plusDefaultEnv = plusNameEnv++-- | Create a 'DefaultEnv' from a list of (Name, ClassDefaults) pairs+-- it is useful if we don't want to poke into the 'ClassDefaults' structure+-- to get the 'Name' of the class, it can be problematic, see #25858+mkDefaultEnv :: [(Name, ClassDefaults)] -> DefaultEnv+mkDefaultEnv = mkNameEnv

@@ -33,6 +33,7 @@ import GHC.Unit.Module (ModuleName, Module) import GHC.Unit.Module.Imported (ImportedModsVal) import GHC.Hs.Extension (GhcTc, GhcRn)+import GHC.Core.Class (Class) import GHC.Core.Coercion import GHC.Core.FamInstEnv (FamFlavor) import GHC.Core.TyCon (TyCon)@@ -479,7 +480,7 @@   | SuggestBindTyVarExplicitly Name    {-| Suggest a default declaration; e.g @default Cls (Ty1, Ty2)@ -}-  | SuggestDefaultDeclaration TyCon [Type]+  | SuggestDefaultDeclaration Class [Type]    {-| Suggest using explicit deriving strategies for a deriving clause. 

@@ -1538,39 +1538,87 @@   --- Given a type already assumed to have been normalized by topNormaliseType,--- unpackable_type_datacons ty = Just datacons--- iff ty is of the form---     T ty1 .. tyn--- and T is an algebraic data type (not newtype), in which no data--- constructors have existentials, and datacons is the list of data--- constructors of T. unpackable_type_datacons :: Type -> Maybe [DataCon]+-- Given a type already assumed to have been normalized by topNormaliseType,+--    unpackable_type_datacons (T ty1 .. tyn) = Just datacons+-- iff the type can be unpacked (see Note [Unpacking GADTs and existentials])+-- and `datacons` are the data constructors of T unpackable_type_datacons ty   | Just (tc, _) <- splitTyConApp_maybe ty-  , not (isNewTyCon tc)  -- Even though `ty` has been normalised, it could still-                         -- be a /recursive/ newtype, so we must check for that+  , not (isNewTyCon tc)+      -- isNewTyCon: even though `ty` has been normalised, whic includes looking+      -- through newtypes, it could still be a /recursive/ newtype, so we must+      -- check for that case   , Just cons <- tyConDataCons_maybe tc-  , not (null cons)      -- Don't upack nullary sums; no need.-                         -- They already take zero bits-  , all (null . dataConExTyCoVars) cons-  = Just cons -- See Note [Unpacking GADTs and existentials]+  , unpackable_cons cons+  = Just cons   | otherwise   = Nothing+  where+    unpackable_cons :: [DataCon] -> Bool+    -- True if we can unpack a value of type (T t1 .. tn),+    -- where T is an algebraic data type with these constructors+    -- See Note [Unpacking GADTs and existentials]+    unpackable_cons []   -- Don't unpack nullary sums; no need.+      = False            -- They already take zero bits; see (UC0) +    unpackable_cons [con]   -- Exactly one data constructor; see (UC1)+      = null (dataConExTyCoVars con)++    unpackable_cons cons  -- More than one data constructor; see (UC2)+      = all isVanillaDataCon cons+ {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is nothing stopping us unpacking a data type with equality-components, like-  data Equal a b where-    Equal :: Equal a a+Can we unpack a value of an algebraic data type T? For example+   data D a = MkD {-# UNPACK #-} (T a)+Can we unpack that (T a) field? -And it'd be fine to unpack a product type with existential components-too, but that would require a bit more plumbing, so currently we don't.+Three cases to consider in `unpackable_cons` -So for now we require: null (dataConExTyCoVars data_con)-See #14978+(UC0) No data constructors; a nullary sum type.  This already takes zero+      bits so there is no point in unpacking it.++(UC1) Single-constructor types (products).  We can just represent it by+   its fields. For example, if `T` is defined as:+      data T a = MkT a a Int+   then we can unpack it as follows.  The worker for MkD takes three unpacked fields:+       data D a = MkD a a Int+       $MkD :: T a -> D a+       $MkD (MkT a1 a2 i) = MkD a1 a2 i++   We currently /can't/ do this if T has existentially-bound type variables,+   hence:   null (dataConExTyCoVars con)   in `unpackable_cons`.+   But see also (UC3) below.++   But we /can/ do it for (some) GADTs, such as:+      data Equal a b where { Equal :: Equal a a }+      data Wom a where { Wom1 :: Int -> Wom Bool }+   We will get a MkD constructor that includes some coercion arguments,+   but that is fine.   See #14978.  We still can't accommodate existentials,+   but these particular examples don't use existentials.++(UC2) Multi-constructor types, e.g.+        data T a = T1 a | T2 Int a+  Here we unpack the field to an unboxed sum type, thus:+    data D a = MkD (# a | (# Int, a #) #)++  However, now we can't deal with GADTs at all, because we'd need an+  unboxed sum whose component was a unboxed tuple, whose component(s)+  have kind (CONSTRAINT r); and that's not well-kinded.  Hence the+    all isVanillaDataCon+  condition in `unpackable_cons`. See #25672.++(UC3)  For single-constructor types, with some more plumbing we could+   allow existentials. e.g.+       data T a = forall b. MkT a (b->Int) b+   could unpack to+       data D a = forall b. MkD a (b->Int) b+       $MkD :: T a -> D a+       $MkD (MkT @b x f y) = MkD @b x f y+   Eminently possible, but more plumbing needed.+  Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -123,7 +123,8 @@             , fUNTyConName, unrestrictedFunTyConName             , oneDataConName             , listTyConName-            , manyDataConName ]+            , manyDataConName+            , soloDataConName ]           || isJust (isTupleTyOcc_maybe mod occ)           || isJust (isSumTyOcc_maybe mod occ) 

@@ -295,13 +295,15 @@ mkNoCount :: GenTickish pass -> GenTickish pass mkNoCount n | not (tickishCounts n)   = n             | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"-mkNoCount n@ProfNote{}                = n {profNoteCount = False}+mkNoCount n@ProfNote{}                = let n' = n {profNoteCount = False}+                                        in assert (profNoteCount n) n' mkNoCount _                           = panic "mkNoCount: Undefined split!"  mkNoScope :: GenTickish pass -> GenTickish pass mkNoScope n | tickishScoped n == NoScope  = n             | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"-mkNoScope n@ProfNote{}                    = n {profNoteScope = False}+mkNoScope n@ProfNote{}                    = let n' = n {profNoteScope = False}+                                            in assert (profNoteCount n) n' mkNoScope _                               = panic "mkNoScope: Undefined split!"  -- | Return @True@ if this source annotation compiles to some backend

@@ -641,6 +641,7 @@ -- A 'ForAllTyBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] -- -- A 'TyVarBinder' is a binder with only TyVar type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag

@@ -28,6 +28,7 @@  import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch+import GHC.Types.DefaultEnv (DefaultEnv) import GHC.Types.TypeEnv import GHC.Types.Unique.DSet @@ -87,6 +88,7 @@                             , n_rules_in = length builtinRules                             , n_rules_out = 0                             }+  , eps_defaults         = emptyModuleEnv   }  @@ -163,7 +165,8 @@         eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external                                                          -- packages, keyed off the module that declared them -        eps_stats :: !EpsStats                 -- ^ Statistics about what was loaded from external packages+        eps_stats :: !EpsStats,                 -- ^ Statistics about what was loaded from external packages+        eps_defaults :: !(ModuleEnv DefaultEnv) -- ^ Default declarations exported by external packages   }  -- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.

@@ -10,7 +10,7 @@  import GHC.Types.Avail import GHC.Types.CompleteMatch-import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv )+import GHC.Types.DefaultEnv import GHC.Types.TypeEnv import GHC.Types.Annotations ( Annotation ) 

@@ -9,9 +9,19 @@ // // 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,6,7,0)-HsWord64 ghc_unique_counter64 = 0;-#elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)++#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)

@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.12.2+Version: 9.12.3 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -130,16 +130,16 @@                    exceptions == 0.10.*,                    semaphore-compat,                    stm,-                   ghc-boot   == 9.12.2,-                   ghc-heap   == 9.12.2,-                   ghci == 9.12.2+                   ghc-boot   == 9.12.3,+                   ghc-heap   == 9.12.3,+                   ghci == 9.12.3      if flag(bootstrap)       Build-Depends:-        ghc-boot-th-next     == 9.12.2+        ghc-boot-th-next     == 9.12.3     else       Build-Depends:-        ghc-boot-th          == 9.12.2+        ghc-boot-th          == 9.12.3      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.15@@ -643,6 +643,8 @@         GHC.Parser.Errors.Types         GHC.Parser.Header         GHC.Parser.Lexer+        GHC.Parser.Lexer.Interface+        GHC.Parser.Lexer.String         GHC.Parser.HaddockLex         GHC.Parser.PostProcess         GHC.Parser.PostProcess.Haddock

@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-parser-version: 9.12.2.20250421+version: 9.12.3.20251228 license: BSD-3-Clause license-file: LICENSE category: Development@@ -90,11 +90,17 @@     if impl(ghc >= 8.8.1)         ghc-options: -fno-safe-haskell     if flag(threaded-rts)-        ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+        if impl(ghc < 9.12.3)+            ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+        else+            ghc-options: -fobject-code -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS         cpp-options: -DTHREADED_RTS   -DBOOTSTRAP_TH     else-        ghc-options: -fobject-code -package=ghc-boot-th+        if impl(ghc < 9.12.3)+           ghc-options: -fobject-code -package=ghc-boot-th+        else+           ghc-options: -fobject-code         cpp-options:   -DBOOTSTRAP_TH     if !os(windows)         build-depends: unix@@ -107,6 +113,7 @@         bytestring >= 0.11.4 && < 0.13,         time >= 1.4 && < 1.15,         filepath >= 1.5 && < 1.6,+        hpc >= 0.6 && < 0.8,         os-string >= 2.0.1 && < 2.1,         exceptions == 0.10.*,         parsec,@@ -169,6 +176,7 @@     hs-source-dirs:         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build+        libraries/ghc-internal/src         libraries/ghc-platform/src         libraries/template-haskell         libraries/ghc-platform@@ -182,6 +190,10 @@         GHC.Parser     exposed-modules:         GHC.BaseDir+        GHC.Boot.TH.Lib.Map+        GHC.Boot.TH.Ppr+        GHC.Boot.TH.PprLib+        GHC.Boot.TH.Syntax         GHC.Builtin.Names         GHC.Builtin.PrimOps         GHC.Builtin.PrimOps.Ids@@ -371,6 +383,10 @@         GHC.Iface.Recomp.Binary         GHC.Iface.Syntax         GHC.Iface.Type+        GHC.Internal.ForeignSrcLang+        GHC.Internal.LanguageExtensions+        GHC.Internal.Lexeme+        GHC.Internal.TH.Syntax         GHC.JS.Ident         GHC.JS.JStg.Monad         GHC.JS.JStg.Syntax@@ -393,6 +409,8 @@         GHC.Parser.HaddockLex         GHC.Parser.Header         GHC.Parser.Lexer+        GHC.Parser.Lexer.Interface+        GHC.Parser.Lexer.String         GHC.Parser.PostProcess         GHC.Parser.PostProcess.Haddock         GHC.Parser.String@@ -596,15 +614,3 @@         Language.Haskell.Syntax.Pat         Language.Haskell.Syntax.Specificity         Language.Haskell.Syntax.Type-    if impl(ghc < 9.12.1)-      hs-source-dirs:-        libraries/ghc-internal/src-        libraries/ghc-boot-th-internal-      exposed-modules:-            GHC.Internal.ForeignSrcLang-            GHC.Internal.LanguageExtensions-            GHC.Internal.Lexeme-            GHC.Internal.TH.Syntax-            GHC.Internal.TH.Ppr-            GHC.Internal.TH.PprLib-            GHC.Internal.TH.Lib.Map

@@ -22,10 +22,10 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "9.12.1"+cBooterVersion        = "9.10.1"  cStage                :: String cStage                = show (1 :: Int)  cProjectUnitId :: String-cProjectUnitId = "ghc-9.12.2-inplace"+cProjectUnitId = "ghc-9.12.3-inplace"

@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "383be28ffdddf65b57b7b111bfc89808b4229ebc"+cProjectGitCommitId   = "8b63dfe0a81d08fef5b4acba6e60d80067daa5d7"  cProjectVersion       :: String-cProjectVersion       = "9.12.2"+cProjectVersion       = "9.12.3"  cProjectVersionInt    :: String cProjectVersionInt    = "912"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "2"+cProjectPatchLevel    = "3"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "2"+cProjectPatchLevel1   = "3"  cProjectPatchLevel2   :: String cProjectPatchLevel2   = "0"

@@ -601,3 +601,153 @@ #define OFFSET_spEntry_addr 0 #define REP_spEntry_addr b64 #define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]+#define OFFSET_HsIface_processRemoteCompletion_closure 0+#define REP_HsIface_processRemoteCompletion_closure b64+#define HsIface_processRemoteCompletion_closure(__ptr__) REP_HsIface_processRemoteCompletion_closure[__ptr__+OFFSET_HsIface_processRemoteCompletion_closure]+#define OFFSET_HsIface_runIO_closure 8+#define REP_HsIface_runIO_closure b64+#define HsIface_runIO_closure(__ptr__) REP_HsIface_runIO_closure[__ptr__+OFFSET_HsIface_runIO_closure]+#define OFFSET_HsIface_runNonIO_closure 16+#define REP_HsIface_runNonIO_closure b64+#define HsIface_runNonIO_closure(__ptr__) REP_HsIface_runNonIO_closure[__ptr__+OFFSET_HsIface_runNonIO_closure]+#define OFFSET_HsIface_Z0T_closure 24+#define REP_HsIface_Z0T_closure b64+#define HsIface_Z0T_closure(__ptr__) REP_HsIface_Z0T_closure[__ptr__+OFFSET_HsIface_Z0T_closure]+#define OFFSET_HsIface_True_closure 32+#define REP_HsIface_True_closure b64+#define HsIface_True_closure(__ptr__) REP_HsIface_True_closure[__ptr__+OFFSET_HsIface_True_closure]+#define OFFSET_HsIface_False_closure 40+#define REP_HsIface_False_closure b64+#define HsIface_False_closure(__ptr__) REP_HsIface_False_closure[__ptr__+OFFSET_HsIface_False_closure]+#define OFFSET_HsIface_unpackCString_closure 48+#define REP_HsIface_unpackCString_closure b64+#define HsIface_unpackCString_closure(__ptr__) REP_HsIface_unpackCString_closure[__ptr__+OFFSET_HsIface_unpackCString_closure]+#define OFFSET_HsIface_runFinalizzerBatch_closure 56+#define REP_HsIface_runFinalizzerBatch_closure b64+#define HsIface_runFinalizzerBatch_closure(__ptr__) REP_HsIface_runFinalizzerBatch_closure[__ptr__+OFFSET_HsIface_runFinalizzerBatch_closure]+#define OFFSET_HsIface_stackOverflow_closure 64+#define REP_HsIface_stackOverflow_closure b64+#define HsIface_stackOverflow_closure(__ptr__) REP_HsIface_stackOverflow_closure[__ptr__+OFFSET_HsIface_stackOverflow_closure]+#define OFFSET_HsIface_heapOverflow_closure 72+#define REP_HsIface_heapOverflow_closure b64+#define HsIface_heapOverflow_closure(__ptr__) REP_HsIface_heapOverflow_closure[__ptr__+OFFSET_HsIface_heapOverflow_closure]+#define OFFSET_HsIface_doubleReadException_closure 80+#define REP_HsIface_doubleReadException_closure b64+#define HsIface_doubleReadException_closure(__ptr__) REP_HsIface_doubleReadException_closure[__ptr__+OFFSET_HsIface_doubleReadException_closure]+#define OFFSET_HsIface_allocationLimitExceeded_closure 88+#define REP_HsIface_allocationLimitExceeded_closure b64+#define HsIface_allocationLimitExceeded_closure(__ptr__) REP_HsIface_allocationLimitExceeded_closure[__ptr__+OFFSET_HsIface_allocationLimitExceeded_closure]+#define OFFSET_HsIface_blockedIndefinitelyOnMVar_closure 96+#define REP_HsIface_blockedIndefinitelyOnMVar_closure b64+#define HsIface_blockedIndefinitelyOnMVar_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnMVar_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnMVar_closure]+#define OFFSET_HsIface_blockedIndefinitelyOnSTM_closure 104+#define REP_HsIface_blockedIndefinitelyOnSTM_closure b64+#define HsIface_blockedIndefinitelyOnSTM_closure(__ptr__) REP_HsIface_blockedIndefinitelyOnSTM_closure[__ptr__+OFFSET_HsIface_blockedIndefinitelyOnSTM_closure]+#define OFFSET_HsIface_cannotCompactFunction_closure 112+#define REP_HsIface_cannotCompactFunction_closure b64+#define HsIface_cannotCompactFunction_closure(__ptr__) REP_HsIface_cannotCompactFunction_closure[__ptr__+OFFSET_HsIface_cannotCompactFunction_closure]+#define OFFSET_HsIface_cannotCompactPinned_closure 120+#define REP_HsIface_cannotCompactPinned_closure b64+#define HsIface_cannotCompactPinned_closure(__ptr__) REP_HsIface_cannotCompactPinned_closure[__ptr__+OFFSET_HsIface_cannotCompactPinned_closure]+#define OFFSET_HsIface_cannotCompactMutable_closure 128+#define REP_HsIface_cannotCompactMutable_closure b64+#define HsIface_cannotCompactMutable_closure(__ptr__) REP_HsIface_cannotCompactMutable_closure[__ptr__+OFFSET_HsIface_cannotCompactMutable_closure]+#define OFFSET_HsIface_nonTermination_closure 136+#define REP_HsIface_nonTermination_closure b64+#define HsIface_nonTermination_closure(__ptr__) REP_HsIface_nonTermination_closure[__ptr__+OFFSET_HsIface_nonTermination_closure]+#define OFFSET_HsIface_nestedAtomically_closure 144+#define REP_HsIface_nestedAtomically_closure b64+#define HsIface_nestedAtomically_closure(__ptr__) REP_HsIface_nestedAtomically_closure[__ptr__+OFFSET_HsIface_nestedAtomically_closure]+#define OFFSET_HsIface_noMatchingContinuationPrompt_closure 152+#define REP_HsIface_noMatchingContinuationPrompt_closure b64+#define HsIface_noMatchingContinuationPrompt_closure(__ptr__) REP_HsIface_noMatchingContinuationPrompt_closure[__ptr__+OFFSET_HsIface_noMatchingContinuationPrompt_closure]+#define OFFSET_HsIface_blockedOnBadFD_closure 160+#define REP_HsIface_blockedOnBadFD_closure b64+#define HsIface_blockedOnBadFD_closure(__ptr__) REP_HsIface_blockedOnBadFD_closure[__ptr__+OFFSET_HsIface_blockedOnBadFD_closure]+#define OFFSET_HsIface_runSparks_closure 168+#define REP_HsIface_runSparks_closure b64+#define HsIface_runSparks_closure(__ptr__) REP_HsIface_runSparks_closure[__ptr__+OFFSET_HsIface_runSparks_closure]+#define OFFSET_HsIface_ensureIOManagerIsRunning_closure 176+#define REP_HsIface_ensureIOManagerIsRunning_closure b64+#define HsIface_ensureIOManagerIsRunning_closure(__ptr__) REP_HsIface_ensureIOManagerIsRunning_closure[__ptr__+OFFSET_HsIface_ensureIOManagerIsRunning_closure]+#define OFFSET_HsIface_interruptIOManager_closure 184+#define REP_HsIface_interruptIOManager_closure b64+#define HsIface_interruptIOManager_closure(__ptr__) REP_HsIface_interruptIOManager_closure[__ptr__+OFFSET_HsIface_interruptIOManager_closure]+#define OFFSET_HsIface_ioManagerCapabilitiesChanged_closure 192+#define REP_HsIface_ioManagerCapabilitiesChanged_closure b64+#define HsIface_ioManagerCapabilitiesChanged_closure(__ptr__) REP_HsIface_ioManagerCapabilitiesChanged_closure[__ptr__+OFFSET_HsIface_ioManagerCapabilitiesChanged_closure]+#define OFFSET_HsIface_runHandlersPtr_closure 200+#define REP_HsIface_runHandlersPtr_closure b64+#define HsIface_runHandlersPtr_closure(__ptr__) REP_HsIface_runHandlersPtr_closure[__ptr__+OFFSET_HsIface_runHandlersPtr_closure]+#define OFFSET_HsIface_flushStdHandles_closure 208+#define REP_HsIface_flushStdHandles_closure b64+#define HsIface_flushStdHandles_closure(__ptr__) REP_HsIface_flushStdHandles_closure[__ptr__+OFFSET_HsIface_flushStdHandles_closure]+#define OFFSET_HsIface_runMainIO_closure 216+#define REP_HsIface_runMainIO_closure b64+#define HsIface_runMainIO_closure(__ptr__) REP_HsIface_runMainIO_closure[__ptr__+OFFSET_HsIface_runMainIO_closure]+#define OFFSET_HsIface_Czh_con_info 224+#define REP_HsIface_Czh_con_info b64+#define HsIface_Czh_con_info(__ptr__) REP_HsIface_Czh_con_info[__ptr__+OFFSET_HsIface_Czh_con_info]+#define OFFSET_HsIface_Izh_con_info 232+#define REP_HsIface_Izh_con_info b64+#define HsIface_Izh_con_info(__ptr__) REP_HsIface_Izh_con_info[__ptr__+OFFSET_HsIface_Izh_con_info]+#define OFFSET_HsIface_Fzh_con_info 240+#define REP_HsIface_Fzh_con_info b64+#define HsIface_Fzh_con_info(__ptr__) REP_HsIface_Fzh_con_info[__ptr__+OFFSET_HsIface_Fzh_con_info]+#define OFFSET_HsIface_Dzh_con_info 248+#define REP_HsIface_Dzh_con_info b64+#define HsIface_Dzh_con_info(__ptr__) REP_HsIface_Dzh_con_info[__ptr__+OFFSET_HsIface_Dzh_con_info]+#define OFFSET_HsIface_Wzh_con_info 256+#define REP_HsIface_Wzh_con_info b64+#define HsIface_Wzh_con_info(__ptr__) REP_HsIface_Wzh_con_info[__ptr__+OFFSET_HsIface_Wzh_con_info]+#define OFFSET_HsIface_Ptr_con_info 272+#define REP_HsIface_Ptr_con_info b64+#define HsIface_Ptr_con_info(__ptr__) REP_HsIface_Ptr_con_info[__ptr__+OFFSET_HsIface_Ptr_con_info]+#define OFFSET_HsIface_FunPtr_con_info 280+#define REP_HsIface_FunPtr_con_info b64+#define HsIface_FunPtr_con_info(__ptr__) REP_HsIface_FunPtr_con_info[__ptr__+OFFSET_HsIface_FunPtr_con_info]+#define OFFSET_HsIface_I8zh_con_info 288+#define REP_HsIface_I8zh_con_info b64+#define HsIface_I8zh_con_info(__ptr__) REP_HsIface_I8zh_con_info[__ptr__+OFFSET_HsIface_I8zh_con_info]+#define OFFSET_HsIface_I16zh_con_info 296+#define REP_HsIface_I16zh_con_info b64+#define HsIface_I16zh_con_info(__ptr__) REP_HsIface_I16zh_con_info[__ptr__+OFFSET_HsIface_I16zh_con_info]+#define OFFSET_HsIface_I32zh_con_info 304+#define REP_HsIface_I32zh_con_info b64+#define HsIface_I32zh_con_info(__ptr__) REP_HsIface_I32zh_con_info[__ptr__+OFFSET_HsIface_I32zh_con_info]+#define OFFSET_HsIface_I64zh_con_info 312+#define REP_HsIface_I64zh_con_info b64+#define HsIface_I64zh_con_info(__ptr__) REP_HsIface_I64zh_con_info[__ptr__+OFFSET_HsIface_I64zh_con_info]+#define OFFSET_HsIface_W8zh_con_info 320+#define REP_HsIface_W8zh_con_info b64+#define HsIface_W8zh_con_info(__ptr__) REP_HsIface_W8zh_con_info[__ptr__+OFFSET_HsIface_W8zh_con_info]+#define OFFSET_HsIface_W16zh_con_info 328+#define REP_HsIface_W16zh_con_info b64+#define HsIface_W16zh_con_info(__ptr__) REP_HsIface_W16zh_con_info[__ptr__+OFFSET_HsIface_W16zh_con_info]+#define OFFSET_HsIface_W32zh_con_info 336+#define REP_HsIface_W32zh_con_info b64+#define HsIface_W32zh_con_info(__ptr__) REP_HsIface_W32zh_con_info[__ptr__+OFFSET_HsIface_W32zh_con_info]+#define OFFSET_HsIface_W64zh_con_info 344+#define REP_HsIface_W64zh_con_info b64+#define HsIface_W64zh_con_info(__ptr__) REP_HsIface_W64zh_con_info[__ptr__+OFFSET_HsIface_W64zh_con_info]+#define OFFSET_HsIface_StablePtr_con_info 352+#define REP_HsIface_StablePtr_con_info b64+#define HsIface_StablePtr_con_info(__ptr__) REP_HsIface_StablePtr_con_info[__ptr__+OFFSET_HsIface_StablePtr_con_info]+#define OFFSET_HsIface_StackSnapshot_closure 360+#define REP_HsIface_StackSnapshot_closure b64+#define HsIface_StackSnapshot_closure(__ptr__) REP_HsIface_StackSnapshot_closure[__ptr__+OFFSET_HsIface_StackSnapshot_closure]+#define OFFSET_HsIface_divZZeroException_closure 368+#define REP_HsIface_divZZeroException_closure b64+#define HsIface_divZZeroException_closure(__ptr__) REP_HsIface_divZZeroException_closure[__ptr__+OFFSET_HsIface_divZZeroException_closure]+#define OFFSET_HsIface_underflowException_closure 376+#define REP_HsIface_underflowException_closure b64+#define HsIface_underflowException_closure(__ptr__) REP_HsIface_underflowException_closure[__ptr__+OFFSET_HsIface_underflowException_closure]+#define OFFSET_HsIface_overflowException_closure 384+#define REP_HsIface_overflowException_closure b64+#define HsIface_overflowException_closure(__ptr__) REP_HsIface_overflowException_closure[__ptr__+OFFSET_HsIface_overflowException_closure]+#define OFFSET_HsIface_unpackCStringzh_info 392+#define REP_HsIface_unpackCStringzh_info b64+#define HsIface_unpackCStringzh_info(__ptr__) REP_HsIface_unpackCStringzh_info[__ptr__+OFFSET_HsIface_unpackCStringzh_info]+#define OFFSET_HsIface_unpackCStringUtf8zh_info 400+#define REP_HsIface_unpackCStringUtf8zh_info b64+#define HsIface_unpackCStringUtf8zh_info(__ptr__) REP_HsIface_unpackCStringUtf8zh_info[__ptr__+OFFSET_HsIface_unpackCStringUtf8zh_info]

@@ -2,7 +2,7 @@ -- ./configure.  Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal.  Name: ghc-bin-Version: 9.12.2+Version: 9.12.3 Copyright: XXX -- License: XXX -- License-File: XXX@@ -39,8 +39,8 @@                    filepath   >= 1.5 && < 1.6,                    containers >= 0.5 && < 0.8,                    transformers >= 0.5 && < 0.7,-                   ghc-boot      == 9.12.2,-                   ghc           == 9.12.2+                   ghc-boot      == 9.12.3,+                   ghc           == 9.12.3      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.15@@ -58,7 +58,7 @@         Build-depends:             deepseq        >= 1.4 && < 1.6,             ghc-prim       >= 0.5.0 && < 0.14,-            ghci           == 9.12.2,+            ghci           == 9.12.3,             haskeline      == 0.8.*,             exceptions     == 0.10.*,             time           >= 1.8 && < 1.15

@@ -1,111 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE Safe #-}---- This is a non-exposed internal module------ The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost--- verbatimely to avoid a dependency of 'template-haskell' on the containers package.------ [1] see https://hackage.haskell.org/package/containers-0.5.5.1------ The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.--module GHC.Internal.TH.Lib.Map-    ( Map-    , empty-    , insert-    , GHC.Internal.TH.Lib.Map.lookup-    ) where--import Prelude--data Map k a  = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)-              | Tip--type Size     = Int--empty :: Map k a-empty = Tip-{-# INLINE empty #-}--singleton :: k -> a -> Map k a-singleton k x = Bin 1 k x Tip Tip-{-# INLINE singleton #-}--size :: Map k a -> Int-size Tip              = 0-size (Bin sz _ _ _ _) = sz-{-# INLINE size #-}--lookup :: Ord k => k -> Map k a -> Maybe a-lookup = go-  where-    go _ Tip = Nothing-    go !k (Bin _ kx x l r) = case compare k kx of-      LT -> go k l-      GT -> go k r-      EQ -> Just x-{-# INLINABLE lookup #-}---insert :: Ord k => k -> a -> Map k a -> Map k a-insert = go-  where-    go :: Ord k => k -> a -> Map k a -> Map k a-    go !kx x Tip = singleton kx x-    go !kx x (Bin sz ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go kx x l) r-            GT -> balanceR ky y l (go kx x r)-            EQ -> Bin sz kx x l r-{-# INLINABLE insert #-}--balanceL :: k -> a -> Map k a -> Map k a -> Map k a-balanceL k x l r = case r of-  Tip -> case l of-           Tip -> Bin 1 k x Tip Tip-           (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip-           (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)-           (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)-           (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))-             | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)-             | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)--  (Bin rs _ _ _ _) -> case l of-           Tip -> Bin (1+rs) k x Tip r--           (Bin ls lk lx ll lr)-              | ls > delta*rs  -> case (ll, lr) of-                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)-                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)-                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)-                   (_, _) -> error "Failure in Data.Map.balanceL"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceL #-}--balanceR :: k -> a -> Map k a -> Map k a -> Map k a-balanceR k x l r = case l of-  Tip -> case r of-           Tip -> Bin 1 k x Tip Tip-           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r-           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr-           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)-           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))-             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr-             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)--  (Bin ls _ _ _ _) -> case r of-           Tip -> Bin (1+ls) k x l Tip--           (Bin rs rk rx rl rr)-              | rs > delta*ls  -> case (rl, rr) of-                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)-                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr-                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-                   (_, _) -> error "Failure in Data.Map.balanceR"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceR #-}--delta,ratio :: Int-delta = 3-ratio = 2

@@ -1,1096 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE LambdaCase #-}--- | contains a prettyprinter for the--- Template Haskell datatypes--module GHC.Internal.TH.Ppr where-    -- All of the exports from this module should-    -- be "public" functions.  The main module TH-    -- re-exports them all.--import Text.PrettyPrint (render)-import GHC.Internal.TH.PprLib-import GHC.Internal.TH.Syntax-import Data.Word ( Word8 )-import Data.Char ( toLower, chr )-import Data.List ( intersperse )-import GHC.Show  ( showMultiLineString )-import GHC.Lexeme( isVarSymChar )-import Data.Ratio ( numerator, denominator )-import Data.Foldable ( toList )-import qualified Data.List.NonEmpty as NE-import Prelude hiding ((<>))--nestDepth :: Int-nestDepth = 4--type Precedence = Int-appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence-appPrec  = 6    -- Argument of a function or type application-opPrec   = 5    -- Argument of an infix operator-unopPrec = 4    -- Argument of an unresolved infix operator-funPrec  = 3    -- Argument of a function arrow-qualPrec = 2    -- Forall-qualified type or result of a function arrow-sigPrec  = 1    -- Argument of an explicit type signature-noPrec   = 0    -- Others--parensIf :: Bool -> Doc -> Doc-parensIf True d = parens d-parensIf False d = d----------------------------------pprint :: Ppr a => a -> String-pprint x = render $ to_HPJ_Doc $ ppr x--class Ppr a where-    ppr :: a -> Doc-    ppr_list :: [a] -> Doc-    ppr_list = vcat . map ppr--instance Ppr a => Ppr [a] where-    ppr x = ppr_list x---------------------------------instance Ppr Name where-    ppr v = pprName v---------------------------------instance Ppr Info where-    ppr (TyConI d)     = ppr d-    ppr (ClassI d is)  = ppr d $$ vcat (map ppr is)-    ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)-    ppr (PrimTyConI name arity is_unlifted)-      = text "Primitive"-        <+> (if is_unlifted then text "unlifted" else empty)-        <+> text "type constructor" <+> quotes (ppr name)-        <+> parens (text "arity" <+> int arity)-    ppr (ClassOpI v ty cls)-      = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty-    ppr (DataConI v ty tc)-      = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty-    ppr (PatSynI nm ty) = pprPatSynSig nm ty-    ppr (TyVarI v ty)-      = text "Type variable" <+> ppr v <+> equals <+> ppr ty-    ppr (VarI v ty mb_d)-      = vcat [ppr_sig v ty,-              case mb_d of { Nothing -> empty; Just d -> ppr d }]--ppr_sig :: Name -> Type -> Doc-ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty--pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc-pprFixity _ f _ | f == defaultFixity = empty-pprFixity v (Fixity i d) ns_spec-  = ppr_fix d <+> int i <+> pprNamespaceSpecifier ns_spec <+> pprName' Infix v-    where ppr_fix InfixR = text "infixr"-          ppr_fix InfixL = text "infixl"-          ppr_fix InfixN = text "infix"--pprNamespaceSpecifier :: NamespaceSpecifier -> Doc-pprNamespaceSpecifier NoNamespaceSpecifier = empty-pprNamespaceSpecifier TypeNamespaceSpecifier = text "type"-pprNamespaceSpecifier DataNamespaceSpecifier = text "data"---- | Pretty prints a pattern synonym type signature-pprPatSynSig :: Name -> PatSynType -> Doc-pprPatSynSig nm ty-  = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty---- | Pretty prints a pattern synonym's type; follows the usual--- conventions to print a pattern synonym type compactly, yet--- unambiguously. See the note on 'PatSynType' and the section on--- pattern synonyms in the GHC user's guide for more information.-pprPatSynType :: PatSynType -> Doc-pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))-  | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')-  | null uniTys, null reqs  = noreqs <+> ppr ty'-  | null reqs               = pprForallBndrs uniTys <+> noreqs <+> ppr ty'-  | otherwise               = ppr ty-  where noreqs = text "() =>"-        pprForallBndrs tvs = text "forall" <+> hsep (map ppr tvs) <+> text "."-pprPatSynType ty            = ppr ty---------------------------------instance Ppr Module where-  ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)--instance Ppr ModuleInfo where-  ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)---------------------------------instance Ppr Exp where-    ppr = pprExp noPrec--pprPrefixOcc :: Name -> Doc--- Print operators with parens around them-pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)--isSymOcc :: Name -> Bool-isSymOcc n-  = case nameBase n of-      []    -> True  -- Empty name; weird-      (c:_) -> isVarSymChar c-                   -- c.f. isVarSymChar in GHC itself--pprInfixExp :: Exp -> Doc-pprInfixExp (VarE v) = pprName' Infix v-pprInfixExp (ConE v) = pprName' Infix v-pprInfixExp (UnboundVarE v) = pprName' Infix v--- This case will only ever be reached in exceptional circumstances.--- For example, when printing an error message in case of a malformed expression.-pprInfixExp e = text "`" <> ppr e <> text "`"--pprExp :: Precedence -> Exp -> Doc-pprExp _ (VarE v)     = pprName' Applied v-pprExp _ (ConE c)     = pprName' Applied c-pprExp i (LitE l)     = pprLit i l-pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1-                                              <+> pprExp appPrec e2-pprExp i (AppTypeE e t)- = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t-pprExp _ (ParensE e)  = parens (pprExp noPrec e)-pprExp i (UInfixE e1 op e2)- = parensIf (i > unopPrec) $ pprExp unopPrec e1-                         <+> pprInfixExp op-                         <+> pprExp unopPrec e2-pprExp i (InfixE (Just e1) op (Just e2))- = parensIf (i >= opPrec) $ pprExp opPrec e1-                        <+> pprInfixExp op-                        <+> pprExp opPrec e2-pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1-                                    <+> pprInfixExp op-                                    <+> pprMaybeExp noPrec me2-pprExp i (LamE [] e) = pprExp i e -- #13856-pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)-                                           <+> text "->" <+> ppr e-pprExp i (LamCaseE ms)-  = parensIf (i > noPrec) $ text "\\case" $$ braces (semiSep ms)-pprExp i (LamCasesE ms)-  = parensIf (i > noPrec) $ text "\\cases" $$ braces (semi_sep ms)-  where semi_sep = sep . punctuate semi . map (pprClause False)-pprExp i (TupE es)-  | [Just e] <- es-  = pprExp i (ConE (tupleDataName 1) `AppE` e)-  | otherwise-  = parens (commaSepWith (pprMaybeExp noPrec) es)-pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es)-pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity--- Nesting in Cond is to avoid potential problems in do statements-pprExp i (CondE guard true false)- = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,-                       nest 1 $ text "then" <+> ppr true,-                       nest 1 $ text "else" <+> ppr false]-pprExp i (MultiIfE alts)-  = parensIf (i > noPrec) $ vcat $-      case alts of-        []            -> [text "if {}"]-        (alt : alts') -> text "if" <+> pprGuarded arrow alt-                         : map (nest 3 . pprGuarded arrow) alts'-pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_-                                             $$ text " in" <+> ppr e-  where-    pprDecs []  = empty-    pprDecs [d] = ppr d-    pprDecs ds  = braces (semiSep ds)--pprExp i (CaseE e ms)- = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"-                        $$ braces (semiSep ms)-pprExp i (DoE m ss_) = parensIf (i > noPrec) $-    pprQualifier m <> text "do" <+> pprStms ss_-  where-    pprQualifier Nothing = empty-    pprQualifier (Just modName) = text (modString modName) <> char '.'-    pprStms []  = empty-    pprStms [s] = ppr s-    pprStms ss  = braces (semiSep ss)-pprExp i (MDoE m ss_) = parensIf (i > noPrec) $-    pprQualifier m <> text "mdo" <+> pprStms ss_-  where-    pprQualifier Nothing = empty-    pprQualifier (Just modName) = text (modString modName) <> char '.'-    pprStms []  = empty-    pprStms [s] = ppr s-    pprStms ss  = braces (semiSep ss)--pprExp _ (CompE []) = text "<<Empty CompExp>>"--- This will probably break with fixity declarations - would need a ';'-pprExp _ (CompE ss) =-    if null ss'-       -- If there are no statements in a list comprehension besides the last-       -- one, we simply treat it like a normal list.-       then text "[" <> ppr s <> text "]"-       else text "[" <> ppr s-        <+> bar-        <+> commaSep ss'-         <> text "]"-  where s = last ss-        ss' = init ss-pprExp _ (ArithSeqE d) = ppr d-pprExp _ (ListE es) = brackets (commaSep es)-pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e-                                          <+> dcolon <+> pprType sigPrec t-pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)-pprExp i (StaticE e) = parensIf (i >= appPrec) $-                         text "static"<+> pprExp appPrec e-pprExp _ (UnboundVarE v) = pprName' Applied v-pprExp _ (LabelE s) = text "#" <> text s-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-pprExp i (TypeE t) = parensIf (i > noPrec) $ text "type" <+> ppr t-pprExp i (ForallVisE tvars body) =-  parensIf (i >= funPrec) $ sep [pprForallVis tvars [], pprExp qualPrec body]-pprExp i (ForallE tvars body) =-  parensIf (i >= funPrec) $ sep [pprForall tvars [], pprExp qualPrec body]-pprExp i (ConstrainedE ctx body) =-  parensIf (i >= funPrec) $ sep [pprCtxWith pprExp ctx, pprExp qualPrec body]--pprFields :: [(Name,Exp)] -> Doc-pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)--pprMaybeExp :: Precedence -> Maybe Exp -> Doc-pprMaybeExp _ Nothing = empty-pprMaybeExp i (Just e) = pprExp i e---------------------------------instance Ppr Stmt where-    ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e-    ppr (LetS ds) = text "let" <+> (braces (semiSep ds))-    ppr (NoBindS e) = ppr e-    ppr (ParS sss) = sep $ punctuate bar-                         $ map commaSep sss-    ppr (RecS ss) = text "rec" <+> (braces (semiSep ss))---------------------------------instance Ppr Match where-    ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs-                        $$ where_clause ds--pprMatchPat :: Pat -> Doc--- Everything except pattern signatures bind more tightly than (->)-pprMatchPat p@(SigP {}) = parens (ppr p)-pprMatchPat p           = ppr p---------------------------------pprGuarded :: Doc -> (Guard, Exp) -> Doc-pprGuarded eqDoc (guard, expr) = case guard of-  NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr-  PatG    stmts     -> bar <+> vcat (punctuate comma $ map ppr stmts) $$-                         nest nestDepth (eqDoc <+> ppr expr)---------------------------------pprBody :: Bool -> Body -> Doc-pprBody eq body = case body of-    GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs-    NormalB  e  -> eqDoc <+> ppr e-  where eqDoc | eq        = equals-              | otherwise = arrow---------------------------------pprClause :: Bool -> Clause -> Doc-pprClause eqDoc (Clause ps rhs ds)-  = hsep (map (pprPat appPrec) ps) <+> pprBody eqDoc rhs-    $$ where_clause ds---------------------------------instance Ppr Lit where-  ppr = pprLit noPrec--pprLit :: Precedence -> Lit -> Doc-pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)-                                    (integer x <> char '#')-pprLit _ (WordPrimL x)    = integer x <> text "##"-pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)-                                    (float (fromRational x) <> char '#')-pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)-                                    (double (fromRational x) <> text "##")-pprLit i (IntegerL x)    = parensIf (i > noPrec && x < 0) (integer x)-pprLit _ (CharL c)       = text (show c)-pprLit _ (CharPrimL c)   = text (show c) <> char '#'-pprLit _ (StringL s)     = pprString s-pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'-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-  -- or can't be represented as Double, show as fraction-  = parensIf (i > noPrec) $-    integer (numerator rat) <+> char '/' <+> integer (denominator rat)-  | 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)-  | 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 = 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-        withoutFactor _ 0 = 0-        withoutFactor p n-          | (n', 0) <- divMod n p = withoutFactor p n'-          | otherwise = n-        -- | Expects the argument 0 <= x < 1-        decimals :: Rational -> Doc-        decimals x-          | x == 0 = empty-          | otherwise = integer n <> decimals d-          where (n, d) = properFraction (x * 10)--bytesToString :: [Word8] -> String-bytesToString = map (chr . fromIntegral)--pprString :: String -> Doc--- Print newlines as newlines with Haskell string escape notation,--- not as '\n'.  For other non-printables use regular escape notation.-pprString s = vcat (map text (showMultiLineString s))---------------------------------instance Ppr Pat where-    ppr = pprPat noPrec--pprPat :: Precedence -> Pat -> Doc-pprPat i (LitP l)     = pprLit i l-pprPat _ (VarP v)     = pprName' Applied v-pprPat i (TupP ps)-  | [_] <- ps-  = pprPat i (ConP (tupleDataName 1) [] ps)-  | otherwise-  = parens (commaSep ps)-pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)-pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity-pprPat i (ConP s ts ps)  = parensIf (i >= appPrec) $-      pprName' Applied s-  <+> sep (map (\t -> char '@' <> pprParendType t) ts)-  <+> sep (map (pprPat appPrec) ps)-pprPat _ (ParensP p)  = parens $ pprPat noPrec p-pprPat i (UInfixP p1 n p2)-                      = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>-                                                 pprName' Infix n   <+>-                                                 pprPat unopPrec p2)-pprPat i (InfixP p1 n p2)-                      = parensIf (i >= opPrec) (pprPat opPrec p1 <+>-                                                pprName' Infix n <+>-                                                pprPat opPrec p2)-pprPat i (TildeP p)   = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p-pprPat i (BangP p)    = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p-pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"-                                                      <> pprPat appPrec p-pprPat _ WildP        = text "_"-pprPat _ (RecP nm fs)- = parens $     pprName' Applied nm-            <+> braces (sep $ punctuate comma $-                        map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs)-pprPat _ (ListP ps) = brackets (commaSep ps)-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t-pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p-pprPat _ (TypeP t) = parens $ text "type" <+> ppr t-pprPat _ (InvisP t) = parens $ text "@" <+> ppr t-pprPat _ (OrP t) = parens $ semiSep (NE.toList t)---------------------------------instance Ppr Dec where-    ppr = ppr_dec True--ppr_dec :: Bool     -- ^ declaration on the toplevel?-        -> Dec-        -> Doc-ppr_dec isTop (FunD f cs)   = layout $ map (\c -> pprPrefixOcc f <+> ppr c) cs-  where-    layout :: [Doc] -> Doc-    layout = if isTop then vcat else semiSepWith id-ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r-                          $$ where_clause ds-ppr_dec _ (TySynD t xs rhs)-  = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs-ppr_dec isTop (DataD ctxt t xs ksig cs decs)-  = ppr_data isTop empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs-ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)-  = ppr_newtype isTop empty ctxt (Just t) (sep (map ppr xs)) ksig c decs-ppr_dec isTop (TypeDataD t xs ksig cs)-  = ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs []-ppr_dec _  (ClassD ctxt c xs fds ds)-  = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds-    $$ where_clause ds-ppr_dec _ (InstanceD o ctxt i ds) =-        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i-                                  $$ where_clause ds-ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t-ppr_dec _ (KiSigD f k)  = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k-ppr_dec _ (ForeignD f)  = ppr f-ppr_dec _ (InfixD fx ns_spec n) = pprFixity n fx ns_spec-ppr_dec _ (DefaultD tys) =-        text "default" <+> parens (sep $ punctuate comma $ map ppr tys)-ppr_dec _ (PragmaD p)   = ppr p-ppr_dec isTop (DataFamilyD tc tvs kind)-  = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind-  where-    maybeFamily | isTop     = text "family"-                | otherwise = empty-    maybeKind | (Just k') <- kind = dcolon <+> ppr k'-              | otherwise = empty-ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)-  = ppr_data isTop (maybeInst <+> ppr_bndrs bndrs)-             ctxt Nothing (ppr ty) ksig cs decs-  where-    maybeInst | isTop     = text "instance"-              | otherwise = empty-ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)-  = ppr_newtype isTop (maybeInst <+> ppr_bndrs bndrs)-                ctxt Nothing (ppr ty) ksig c decs-  where-    maybeInst | isTop     = text "instance"-              | otherwise = empty-ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs))-  = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs)-              Nothing (ppr ty) rhs-  where-    maybeInst | isTop     = text "instance"-              | otherwise = empty-ppr_dec isTop (OpenTypeFamilyD tfhead)-  = text "type" <+> maybeFamily <+> ppr_tf_head tfhead-  where-    maybeFamily | isTop     = text "family"-                | otherwise = empty-ppr_dec _ (ClosedTypeFamilyD tfhead eqns)-  = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")-      nestDepth (vcat (map ppr_eqn eqns))-  where-    ppr_eqn (TySynEqn mb_bndrs lhs rhs)-      = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs-ppr_dec _ (RoleAnnotD name roles)-  = hsep [ text "type role", pprName' Applied name ] <+> hsep (map ppr roles)-ppr_dec _ (StandaloneDerivD ds cxt ty)-  = hsep [ text "deriving"-         , maybe empty ppr_deriv_strategy ds-         , text "instance"-         , pprCxt cxt-         , ppr ty ]-ppr_dec _ (DefaultSigD n ty)-  = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]-ppr_dec _ (PatSynD name args dir pat)-  = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS-  where-    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2-                | otherwise                 = pprName' Applied name <+> ppr args-    pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")-                                              nestDepth-                                              (vcat $ (pprName' Applied name <+>) . ppr <$> cls)-                | otherwise            = ppr pat-ppr_dec _ (PatSynSigD name ty)-  = pprPatSynSig name ty-ppr_dec _ (ImplicitParamBindD n e)-  = hsep [text ('?' : n), text "=", ppr e]--ppr_deriv_strategy :: DerivStrategy -> Doc-ppr_deriv_strategy ds =-  case ds of-    StockStrategy    -> text "stock"-    AnyclassStrategy -> text "anyclass"-    NewtypeStrategy  -> text "newtype"-    ViaStrategy ty   -> text "via" <+> pprParendType ty--ppr_overlap :: Overlap -> Doc-ppr_overlap o = text $-  case o of-    Overlaps      -> "{-# OVERLAPS #-}"-    Overlappable  -> "{-# OVERLAPPABLE #-}"-    Overlapping   -> "{-# OVERLAPPING #-}"-    Incoherent    -> "{-# INCOHERENT #-}"--ppr_data :: Bool     -- ^ declaration on the toplevel?-         -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]-         -> Doc-ppr_data = ppr_typedef "data"--ppr_newtype :: Bool     -- ^ declaration on the toplevel?-            -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]-            -> Doc-ppr_newtype isTop maybeInst ctxt t argsDoc ksig c decs-  = ppr_typedef "newtype" isTop maybeInst ctxt t argsDoc ksig [c] decs--ppr_type_data :: Bool     -- ^ declaration on the toplevel?-              -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]-              -> Doc-ppr_type_data = ppr_typedef "type data"--ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc-ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs-  = sep [text data_or_newtype <+> maybeInst-            <+> pprCxt ctxt-            <+> case t of-                 Just n -> pprName' Applied n <+> argsDoc-                 Nothing -> argsDoc-            <+> ksigDoc <+> maybeWhere,-         nest nestDepth (layout (pref $ map ppr cs)),-         if null decs-           then empty-           else nest nestDepth-              $ vcat $ map ppr_deriv_clause decs]-  where-    pref :: [Doc] -> [Doc]-    pref xs | isGadtDecl = xs-    pref []              = []      -- No constructors; can't happen in H98-    pref (d:ds)          = (char '=' <+> d):map (bar <+>) ds--    layout :: [Doc] -> Doc-    layout | isGadtDecl && not isTop = braces . semiSepWith id-           | otherwise = vcat--    maybeWhere :: Doc-    maybeWhere | isGadtDecl = text "where"-               | otherwise  = empty--    isGadtDecl :: Bool-    isGadtDecl = not (null cs) && all isGadtCon cs-        where isGadtCon (GadtC _ _ _   ) = True-              isGadtCon (RecGadtC _ _ _) = True-              isGadtCon (ForallC _ _ x ) = isGadtCon x-              isGadtCon  _               = False--    ksigDoc = case ksig of-                Nothing -> empty-                Just k  -> dcolon <+> ppr k---ppr_deriv_clause :: DerivClause -> Doc-ppr_deriv_clause (DerivClause ds ctxt)-  = text "deriving" <+> pp_strat_before-                    <+> ppr_cxt_preds appPrec ctxt-                    <+> pp_strat_after-  where-    -- @via@ is unique in that in comes /after/ the class being derived,-    -- so we must special-case it.-    (pp_strat_before, pp_strat_after) =-      case ds of-        Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via)-        _                        -> (maybe empty ppr_deriv_strategy ds, empty)--ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc-ppr_tySyn maybeInst t argsDoc rhs-  = text "type" <+> maybeInst-    <+> case t of-         Just n -> pprName' Applied n <+> argsDoc-         Nothing -> argsDoc-    <+> text "=" <+> ppr rhs--ppr_tf_head :: TypeFamilyHead -> Doc-ppr_tf_head (TypeFamilyHead tc tvs res inj)-  = pprName' Applied tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj-  where-    maybeInj | (Just inj') <- inj = ppr inj'-             | otherwise          = empty--ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc-ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."-ppr_bndrs Nothing = empty---------------------------------instance Ppr FunDep where-    ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)-    ppr_list [] = empty-    ppr_list xs = bar <+> commaSep xs---------------------------------instance Ppr FamilyResultSig where-    ppr NoSig           = empty-    ppr (KindSig k)     = dcolon <+> ppr k-    ppr (TyVarSig bndr) = text "=" <+> ppr bndr---------------------------------instance Ppr InjectivityAnn where-    ppr (InjectivityAnn lhs rhs) =-        bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)---------------------------------instance Ppr Foreign where-    ppr (ImportF callconv safety impent as typ)-       = text "foreign import"-     <+> showtextl callconv-     <+> showtextl safety-     <+> text (show impent)-     <+> pprName' Applied as-     <+> dcolon <+> ppr typ-    ppr (ExportF callconv expent as typ)-        = text "foreign export"-      <+> showtextl callconv-      <+> text (show expent)-      <+> pprName' Applied as-      <+> dcolon <+> ppr typ---------------------------------instance Ppr Pragma where-    ppr (InlineP n inline rm phases)-       = text "{-#"-     <+> ppr inline-     <+> ppr rm-     <+> ppr phases-     <+> pprName' Applied n-     <+> text "#-}"-    ppr (OpaqueP n)-       = text "{-# OPAQUE" <+> pprName' Applied n <+> text "#-}"-    ppr (SpecialiseP n ty inline phases)-       =   text "{-# SPECIALISE"-       <+> maybe empty ppr inline-       <+> ppr phases-       <+> sep [ pprName' Applied n <+> dcolon-               , nest 2 $ ppr ty ]-       <+> text "#-}"-    ppr (SpecialiseInstP inst)-       = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"-    ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)-       = sep [ text "{-# RULES" <+> pprString n <+> ppr phases-             , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs-                                               <+> ppr lhs-             , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]-      where ppr_ty_forall Nothing      = empty-            ppr_ty_forall (Just bndrs) = text "forall"-                                         <+> fsep (map ppr bndrs)-                                         <+> char '.'-            ppr_tm_forall Nothing | null tm_bndrs = empty-            ppr_tm_forall _ = text "forall"-                              <+> fsep (map ppr tm_bndrs)-                              <+> char '.'-    ppr (AnnP tgt expr)-       = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"-      where target1 ModuleAnnotation    = text "module"-            target1 (TypeAnnotation t)  = text "type" <+> pprName' Applied t-            target1 (ValueAnnotation v) = pprName' Applied v-    ppr (LineP line file)-       = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"-    ppr (CompleteP cls mty)-       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)-                <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"-    ppr (SCCP nm str)-       = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}"---------------------------------instance Ppr Inline where-    ppr NoInline  = text "NOINLINE"-    ppr Inline    = text "INLINE"-    ppr Inlinable = text "INLINABLE"---------------------------------instance Ppr RuleMatch where-    ppr ConLike = text "CONLIKE"-    ppr FunLike = empty---------------------------------instance Ppr Phases where-    ppr AllPhases       = empty-    ppr (FromPhase i)   = brackets $ int i-    ppr (BeforePhase i) = brackets $ char '~' <> int i---------------------------------instance Ppr RuleBndr where-    ppr (RuleVar n)         = ppr n-    ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty---------------------------------instance Ppr Clause where-    ppr = pprClause True---------------------------------instance Ppr Con where-    ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts)--    ppr (RecC c vsts)-        = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))--    ppr (InfixC st1 c st2) = pprBangType st1-                         <+> pprName' Infix c-                         <+> pprBangType st2--    ppr (ForallC ns ctxt (GadtC cs sts ty))-        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt-      <+> pprGadtRHS sts ty--    ppr (ForallC ns ctxt (RecGadtC cs vsts ty))-        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt-      <+> pprRecFields vsts ty--    ppr (ForallC ns ctxt con)-        = pprForall ns ctxt <+> ppr con--    ppr (GadtC cs sts ty)-        = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty--    ppr (RecGadtC cs vsts ty)-        = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty--instance Ppr PatSynDir where-  ppr Unidir        = text "<-"-  ppr ImplBidir     = text "="-  ppr (ExplBidir _) = text "<-"-    -- the ExplBidir's clauses are pretty printed together with the-    -- entire pattern synonym; so only print the direction here.--instance Ppr PatSynArgs where-  ppr (PrefixPatSyn args) = sep $ map ppr args-  ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2-  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map (pprName' Applied) sels))--commaSepApplied :: [Name] -> Doc-commaSepApplied = commaSepWith (pprName' Applied)--pprForall :: [TyVarBndr Specificity] -> Cxt -> Doc-pprForall = pprForall' ForallInvis--pprForallVis :: [TyVarBndr ()] -> Cxt -> Doc-pprForallVis = pprForall' ForallVis--pprForall' :: PprFlag flag => ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc-pprForall' fvf tvs cxt-  -- even in the case without any tvs, there could be a non-empty-  -- context cxt (e.g., in the case of pattern synonyms, where there-  -- are multiple forall binders and contexts).-  | [] <- tvs = pprCxt cxt-  | otherwise = text "forall" <+> hsep (map ppr tvs)-                              <+> separator <+> pprCxt cxt-  where-    separator = case fvf of-                  ForallVis   -> text "->"-                  ForallInvis -> char '.'--pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc-pprRecFields vsts ty-    = braces (sep (punctuate comma $ map pprVarBangType vsts))-  <+> arrow <+> ppr ty--pprGadtRHS :: [(Strict, Type)] -> Type -> Doc-pprGadtRHS [] ty-    = ppr ty-pprGadtRHS sts ty-    = sep (punctuate (space <> arrow) (map pprBangType sts))-  <+> arrow <+> ppr ty---------------------------------pprVarBangType :: VarBangType -> Doc--- Slight infelicity: with print non-atomic type with parens-pprVarBangType (v, bang, t) = pprName' Applied v <+> dcolon <+> pprBangType (bang, t)---------------------------------pprBangType :: BangType -> Doc--- Make sure we print------ Con {-# UNPACK #-} a------ rather than------ Con {-# UNPACK #-}a------ when there's no strictness annotation. If there is a strictness annotation,--- it's okay to not put a space between it and the type.-pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t-pprBangType (bt, t) = ppr bt <> pprParendType t---------------------------------instance Ppr Bang where-    ppr (Bang su ss) = ppr su <+> ppr ss---------------------------------instance Ppr SourceUnpackedness where-    ppr NoSourceUnpackedness = empty-    ppr SourceNoUnpack       = text "{-# NOUNPACK #-}"-    ppr SourceUnpack         = text "{-# UNPACK #-}"---------------------------------instance Ppr SourceStrictness where-    ppr NoSourceStrictness = empty-    ppr SourceLazy         = char '~'-    ppr SourceStrict       = char '!'---------------------------------instance Ppr DecidedStrictness where-    ppr DecidedLazy   = empty-    ppr DecidedStrict = char '!'-    ppr DecidedUnpack = text "{-# UNPACK #-} !"---------------------------------{-# DEPRECATED pprVarStrictType-               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}-pprVarStrictType :: (Name, Strict, Type) -> Doc-pprVarStrictType = pprVarBangType---------------------------------{-# DEPRECATED pprStrictType-               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}-pprStrictType :: (Strict, Type) -> Doc-pprStrictType = pprBangType---------------------------------pprType :: Precedence -> Type -> Doc-pprType _ (VarT v)               = pprName' Applied v--- `Applied` is used here instead of `ppr` because of infix names (#13887)-pprType _ (ConT c)               = pprName' Applied c-pprType _ (TupleT 0)             = text "()"-pprType p (TupleT 1)             = pprType p (ConT (tupleTypeName 1))-pprType _ (TupleT n)             = parens (hcat (replicate (n-1) comma))-pprType _ (UnboxedTupleT n)      = hashParens $ hcat $ replicate (n-1) comma-pprType _ (UnboxedSumT arity)    = hashParens $ hsep $ replicate (arity-1) bar-pprType _ ArrowT                 = parens (text "->")-pprType _ MulArrowT              = text "FUN"-pprType _ ListT                  = text "[]"-pprType _ (LitT l)               = pprTyLit l-pprType _ (PromotedT c)          = text "'" <> pprName' Applied c-pprType _ (PromotedTupleT 0)     = text "'()"-pprType p (PromotedTupleT 1)     = pprType p (PromotedT (tupleDataName 1))-pprType _ (PromotedTupleT n)     = quoteParens (hcat (replicate (n-1) comma))-pprType _ PromotedNilT           = text "'[]"-pprType _ PromotedConsT          = text "'(:)"-pprType _ StarT                  = char '*'-pprType _ ConstraintT            = text "Constraint"-pprType _ (SigT ty k)            = parens (ppr ty <+> text "::" <+> ppr k)-pprType _ WildCardT              = char '_'-pprType p t@(InfixT {})          = pprInfixT p t-pprType p t@(UInfixT {})         = pprInfixT p t-pprType p t@(PromotedInfixT {})  = pprInfixT p t-pprType p t@(PromotedUInfixT {}) = pprInfixT p t-pprType _ (ParensT t)            = parens (pprType noPrec t)-pprType p (ImplicitParamT n ty) =-  parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty-pprType _ EqualityT              = text "(~)"-pprType p (ForallT tvars ctxt ty) =-  parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty]-pprType p (ForallVisT tvars ty) =-  parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty]-pprType p t@AppT{}               = pprTyApp p (split t)-pprType p t@AppKindT{}           = pprTyApp p (split t)---------------------------------pprParendType :: Type -> Doc-pprParendType = pprType appPrec--pprInfixT :: Precedence -> Type -> Doc-pprInfixT p = \case-  InfixT x n y          -> with x n y ""  opPrec-  UInfixT x n y         -> with x n y ""  unopPrec-  PromotedInfixT x n y  -> with x n y "'" opPrec-  PromotedUInfixT x n y -> with x n y "'" unopPrec-  t                     -> pprParendType t-  where-    with x n y prefix p' =-      parensIf-        (p >= p')-        (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y)--instance Ppr Type where-    ppr = pprType noPrec-instance Ppr TypeArg where-    ppr (TANormal ty) = ppr ty-    ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)--pprParendTypeArg :: TypeArg -> Doc-pprParendTypeArg (TANormal ty) = pprParendType ty-pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)--isStarT :: Type -> Bool-isStarT StarT = True-isStarT _ = False--{- Note [Pretty-printing kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC's parser only recognises a kind signature in a type when there are-parens around it.  E.g. the parens are required here:-   f :: (Int :: *)-   type instance F Int = (Bool :: *)-So we always print a SigT with parens (see #10050). -}--pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc-pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])-  | p >= funPrec  = parens (pprTyApp noPrec app)-  | c == oneName  = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2]-  | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]-pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =-  parensIf (p >= funPrec) $-    sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->",-         pprType qualPrec arg2]-pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) =-  parensIf (p >= funPrec) $-    sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]-pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) =-  parensIf (p >= opPrec) $-    sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2]-pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg)-pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args)-pprTyApp _ (TupleT n, args)- | length args == n, Just args' <- traverse fromTANormal args- = parens (commaSep args')-pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args)-pprTyApp _ (PromotedTupleT n, args)- | length args == n, Just args' <- traverse fromTANormal args- = quoteParens (commaSep args')-pprTyApp _ (UnboxedTupleT n, args)- | length args == n, Just args' <- traverse fromTANormal args- = hashParens (commaSep args')-pprTyApp _ (UnboxedSumT n, args)- | length args == n, Just args' <- traverse fromTANormal args- = hashParens (sep $ intersperse bar $ map ppr args')-pprTyApp p (fun, args) =-  parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args)--fromTANormal :: TypeArg -> Maybe Type-fromTANormal (TANormal arg) = Just arg-fromTANormal (TyArg _) = Nothing---- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->).-pprFunArgType :: Type -> Doc-pprFunArgType = pprType funPrec--data ForallVisFlag = ForallVis   -- forall a -> {...}-                   | ForallInvis -- forall a.   {...}-  deriving Show--data TypeArg = TANormal Type-             | TyArg Kind--split :: Type -> (Type, [TypeArg])    -- Split into function and args-split t = go t []-    where go (AppT t1 t2) args = go t1 (TANormal t2:args)-          go (AppKindT ty ki) args = go ty (TyArg ki:args)-          go ty           args = (ty, args)--pprTyLit :: TyLit -> Doc-pprTyLit (NumTyLit n) = integer n-pprTyLit (StrTyLit s) = text (show s)-pprTyLit (CharTyLit c) = text (show c)--instance Ppr TyLit where-  ppr = pprTyLit---------------------------------class PprFlag flag where-    pprTyVarBndr :: (TyVarBndr flag) -> Doc--instance PprFlag () where-    pprTyVarBndr (PlainTV nm ())    = ppr nm-    pprTyVarBndr (KindedTV nm () k) = parens (ppr nm <+> dcolon <+> ppr k)--instance PprFlag Specificity where-    pprTyVarBndr (PlainTV nm SpecifiedSpec)    = ppr nm-    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--instance Ppr Role where-    ppr NominalR          = text "nominal"-    ppr RepresentationalR = text "representational"-    ppr PhantomR          = text "phantom"-    ppr InferR            = text "_"---------------------------------pprCtxWith :: Ppr a => (Precedence -> a -> Doc) -> [a] -> Doc-pprCtxWith _ [] = empty-pprCtxWith ppr_fun ts = ppr_ctx_preds_with ppr_fun funPrec ts <+> text "=>"--pprCxt :: Cxt -> Doc-pprCxt = pprCtxWith pprType--ppr_ctx_preds_with :: Ppr a => (Precedence -> a -> Doc) -> Precedence -> [a] -> Doc-ppr_ctx_preds_with _ _ [] = text "()"-ppr_ctx_preds_with f p [t] = f p t-ppr_ctx_preds_with _ _ ts = parens (commaSep ts)--ppr_cxt_preds :: Precedence -> Cxt -> Doc-ppr_cxt_preds = ppr_ctx_preds_with pprType---------------------------------instance Ppr Range where-    ppr = brackets . pprRange-        where pprRange :: Range -> Doc-              pprRange (FromR e) = ppr e <+> text ".."-              pprRange (FromThenR e1 e2) = ppr e1 <> text ","-                                           <+> ppr e2 <+> text ".."-              pprRange (FromToR e1 e2) = ppr e1 <+> text ".." <+> ppr e2-              pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","-                                             <+> ppr e2 <+> text ".."-                                             <+> ppr e3---------------------------------where_clause :: [Dec] -> Doc-where_clause [] = empty-where_clause ds = nest nestDepth $ text "where" <+> braces (semiSepWith (ppr_dec False) ds)--showtextl :: Show a => a -> Doc-showtextl = text . map toLower . show--hashParens :: Doc -> Doc-hashParens d = text "(# " <> d <> text " #)"--quoteParens :: Doc -> Doc-quoteParens d = text "'(" <> d <> text ")"--------------------------------instance Ppr Loc where-  ppr (Loc { loc_module = md-           , loc_package = pkg-           , loc_start = (start_ln, start_col)-           , loc_end = (end_ln, end_col) })-    = hcat [ text pkg, colon, text md, colon-           , parens $ int start_ln <> comma <> int start_col-           , text "-"-           , parens $ int end_ln <> comma <> int end_col ]---- Takes a separator and a pretty-printing function and prints a list of things--- separated by the separator followed by space.-sepWith :: Doc -> (a -> Doc) -> [a] -> Doc-sepWith sepDoc pprFun = sep . punctuate sepDoc . map pprFun---- Takes a list of printable things and prints them separated by commas followed--- by space.-commaSep :: Ppr a => [a] -> Doc-commaSep = commaSepWith ppr---- Takes a list of things and prints them with the given pretty-printing--- function, separated by commas followed by space.-commaSepWith :: (a -> Doc) -> [a] -> Doc-commaSepWith pprFun = sepWith comma pprFun---- Takes a list of printable things and prints them separated by semicolons--- followed by space.-semiSep :: Ppr a => [a] -> Doc-semiSep = sep . punctuate semi . map ppr---- Takes a list of things and prints them with the given pretty-printing--- function, separated by semicolons followed by space.-semiSepWith :: (a -> Doc) -> [a] -> Doc-semiSepWith pprFun = sepWith semi pprFun---- Prints out the series of vertical bars that wraps an expression or pattern--- used in an unboxed sum.-unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc-unboxedSumBars d alt arity = hashParens $-    bars (alt-1) <> d <> bars (arity - alt)-  where-    bars i = hsep (replicate i bar)---- Text containing the vertical bar character.-bar :: Doc-bar = char '|'

@@ -1,226 +0,0 @@-{-# LANGUAGE FlexibleInstances, Safe #-}---- | Monadic front-end to Text.PrettyPrint--module GHC.Internal.TH.PprLib (--        -- * The document type-        Doc,            -- Abstract, instance of Show-        PprM,--        -- * Primitive Documents-        empty,-        semi, comma, colon, dcolon, space, equals, arrow,-        lparen, rparen, lbrack, rbrack, lbrace, rbrace,--        -- * Converting values into documents-        text, char, ptext,-        int, integer, float, double, rational,--        -- * Wrapping documents in delimiters-        parens, brackets, braces, quotes, doubleQuotes,--        -- * Combining documents-        (<>), (<+>), hcat, hsep,-        ($$), ($+$), vcat,-        sep, cat,-        fsep, fcat,-        nest,-        hang, punctuate,--        -- * Predicates on documents-        isEmpty,--    to_HPJ_Doc, pprName, pprName'-  ) where---import GHC.Internal.TH.Syntax-    (Uniq, Name(..), showName', NameFlavour(..), NameIs(..))-import qualified Text.PrettyPrint as HPJ-import Control.Monad (liftM, liftM2, ap)-import GHC.Internal.TH.Lib.Map ( Map )-import qualified GHC.Internal.TH.Lib.Map as Map ( lookup, insert, empty )-import Prelude hiding ((<>))--infixl 6 <>-infixl 6 <+>-infixl 5 $$, $+$---- ------------------------------------------------------------------------------ The interface---- The primitive Doc values--instance Show Doc where-   show d = HPJ.render (to_HPJ_Doc d)--isEmpty :: Doc    -> PprM Bool;  -- ^ Returns 'True' if the document is empty--empty   :: Doc;                 -- ^ An empty document-semi    :: Doc;                 -- ^ A ';' character-comma   :: Doc;                 -- ^ A ',' character-colon   :: Doc;                 -- ^ A ':' character-dcolon  :: Doc;                 -- ^ A "::" string-space   :: Doc;                 -- ^ A space character-equals  :: Doc;                 -- ^ A '=' character-arrow   :: Doc;                 -- ^ A "->" string-lparen  :: Doc;                 -- ^ A '(' character-rparen  :: Doc;                 -- ^ A ')' character-lbrack  :: Doc;                 -- ^ A '[' character-rbrack  :: Doc;                 -- ^ A ']' character-lbrace  :: Doc;                 -- ^ A '{' character-rbrace  :: Doc;                 -- ^ A '}' character--text     :: String   -> Doc-ptext    :: String   -> Doc-char     :: Char     -> Doc-int      :: Int      -> Doc-integer  :: Integer  -> Doc-float    :: Float    -> Doc-double   :: Double   -> Doc-rational :: Rational -> Doc---parens       :: Doc -> Doc;     -- ^ Wrap document in @(...)@-brackets     :: Doc -> Doc;     -- ^ Wrap document in @[...]@-braces       :: Doc -> Doc;     -- ^ Wrap document in @{...}@-quotes       :: Doc -> Doc;     -- ^ Wrap document in @\'...\'@-doubleQuotes :: Doc -> Doc;     -- ^ Wrap document in @\"...\"@---- Combining @Doc@ values--(<>)   :: Doc -> Doc -> Doc;     -- ^Beside-hcat   :: [Doc] -> Doc;          -- ^List version of '<>'-(<+>)  :: Doc -> Doc -> Doc;     -- ^Beside, separated by space-hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'--($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no-                                 -- overlap it \"dovetails\" the two-($+$)  :: Doc -> Doc -> Doc;     -- ^Above, without dovetailing.-vcat   :: [Doc] -> Doc;          -- ^List version of '$$'--cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat-sep    :: [Doc] -> Doc;          -- ^ Either hsep or vcat-fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of cat-fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of sep--nest   :: Int -> Doc -> Doc;     -- ^ Nested----- GHC-specific ones.--hang :: Doc -> Int -> Doc -> Doc;      -- ^ @hang d1 n d2 = sep [d1, nest n d2]@-punctuate :: Doc -> [Doc] -> [Doc]-   -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@---- ------------------------------------------------------------------------------ The "implementation"--type State = (Map Name Name, Uniq)-data PprM a = PprM { runPprM :: State -> (a, State) }--pprName :: Name -> Doc-pprName = pprName' Alone--pprName' :: NameIs -> Name -> Doc-pprName' ni n@(Name o (NameU _))- = PprM $ \s@(fm, i)-        -> let (n', s') = case Map.lookup n fm of-                         Just d -> (d, s)-                         Nothing -> let n'' = Name o (NameU i)-                                    in (n'', (Map.insert n n'' fm, i + 1))-           in (HPJ.text $ showName' ni n', s')-pprName' ni n = text $ showName' ni n--{--instance Show Name where-  show (Name occ (NameU u))    = occString occ ++ "_" ++ show (I# u)-  show (Name occ NameS)        = occString occ-  show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ--data Name = Name OccName NameFlavour--data NameFlavour-  | NameU Int#                  -- A unique local name--}--to_HPJ_Doc :: Doc -> HPJ.Doc-to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0)--instance Functor PprM where-      fmap = liftM--instance Applicative PprM where-      pure x = PprM $ \s -> (x, s)-      (<*>) = ap--instance Monad PprM where-    m >>= k  = PprM $ \s -> let (x, s') = runPprM m s-                            in runPprM (k x) s'--type Doc = PprM HPJ.Doc---- The primitive Doc values--isEmpty = liftM HPJ.isEmpty--empty = return HPJ.empty-semi = return HPJ.semi-comma = return HPJ.comma-colon = return HPJ.colon-dcolon = return $ HPJ.text "::"-space = return HPJ.space-equals = return HPJ.equals-arrow = return $ HPJ.text "->"-lparen = return HPJ.lparen-rparen = return HPJ.rparen-lbrack = return HPJ.lbrack-rbrack = return HPJ.rbrack-lbrace = return HPJ.lbrace-rbrace = return HPJ.rbrace--text = return . HPJ.text-ptext = return . HPJ.ptext-char = return . HPJ.char-int = return . HPJ.int-integer = return . HPJ.integer-float = return . HPJ.float-double = return . HPJ.double-rational = return . HPJ.rational---parens = liftM HPJ.parens-brackets = liftM HPJ.brackets-braces = liftM HPJ.braces-quotes = liftM HPJ.quotes-doubleQuotes = liftM HPJ.doubleQuotes---- Combining @Doc@ values--(<>) = liftM2 (HPJ.<>)-hcat = liftM HPJ.hcat . sequence-(<+>) = liftM2 (HPJ.<+>)-hsep = liftM HPJ.hsep . sequence--($$) = liftM2 (HPJ.$$)-($+$) = liftM2 (HPJ.$+$)-vcat = liftM HPJ.vcat . sequence--cat  = liftM HPJ.cat . sequence-sep  = liftM HPJ.sep . sequence-fcat = liftM HPJ.fcat . sequence-fsep = liftM HPJ.fsep . sequence--nest n = liftM (HPJ.nest n)--hang d1 n d2 = do d1' <- d1-                  d2' <- d2-                  return (HPJ.hang d1' n d2')---- punctuate uses the same definition as Text.PrettyPrint-punctuate _ []     = []-punctuate p (d:ds) = go d ds-                   where-                     go d' [] = [d']-                     go d' (e:es) = (d' <> p) : go e es

@@ -0,0 +1,111 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Safe #-}++-- This is a non-exposed internal module+--+-- The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost+-- verbatimely to avoid a dependency of 'template-haskell' on the containers package.+--+-- [1] see https://hackage.haskell.org/package/containers-0.5.5.1+--+-- The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.++module GHC.Boot.TH.Lib.Map+    ( Map+    , empty+    , insert+    , GHC.Boot.TH.Lib.Map.lookup+    ) where++import Prelude++data Map k a  = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)+              | Tip++type Size     = Int++empty :: Map k a+empty = Tip+{-# INLINE empty #-}++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip+{-# INLINE singleton #-}++size :: Map k a -> Int+size Tip              = 0+size (Bin sz _ _ _ _) = sz+{-# INLINE size #-}++lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+  where+    go _ Tip = Nothing+    go !k (Bin _ kx x l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> Just x+{-# INLINABLE lookup #-}+++insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+  where+    go :: Ord k => k -> a -> Map k a -> Map k a+    go !kx x Tip = singleton kx x+    go !kx x (Bin sz ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go kx x l) r+            GT -> balanceR ky y l (go kx x r)+            EQ -> Bin sz kx x l r+{-# INLINABLE insert #-}++balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case r of+  Tip -> case l of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+           (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+           (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+           (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+             | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+             | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++  (Bin rs _ _ _ _) -> case l of+           Tip -> Bin (1+rs) k x Tip r++           (Bin ls lk lx ll lr)+              | ls > delta*rs  -> case (ll, lr) of+                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+                   (_, _) -> error "Failure in Data.Map.balanceL"+              | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceL #-}++balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++  (Bin ls _ _ _ _) -> case r of+           Tip -> Bin (1+ls) k x l Tip++           (Bin rs rk rx rl rr)+              | rs > delta*ls  -> case (rl, rr) of+                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+                   (_, _) -> error "Failure in Data.Map.balanceR"+              | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceR #-}++delta,ratio :: Int+delta = 3+ratio = 2

@@ -0,0 +1,1096 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE LambdaCase #-}+-- | contains a prettyprinter for the+-- Template Haskell datatypes++module GHC.Boot.TH.Ppr where+    -- All of the exports from this module should+    -- be "public" functions.  The main module TH+    -- re-exports them all.++import Text.PrettyPrint (render)+import GHC.Boot.TH.PprLib+import GHC.Boot.TH.Syntax+import Data.Word ( Word8 )+import Data.Char ( toLower, chr )+import Data.List ( intersperse )+import GHC.Show  ( showMultiLineString )+import GHC.Lexeme( isVarSymChar )+import Data.Ratio ( numerator, denominator )+import Data.Foldable ( toList )+import qualified Data.List.NonEmpty as NE+import Prelude hiding ((<>))++nestDepth :: Int+nestDepth = 4++type Precedence = Int+appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence+appPrec  = 6    -- Argument of a function or type application+opPrec   = 5    -- Argument of an infix operator+unopPrec = 4    -- Argument of an unresolved infix operator+funPrec  = 3    -- Argument of a function arrow+qualPrec = 2    -- Forall-qualified type or result of a function arrow+sigPrec  = 1    -- Argument of an explicit type signature+noPrec   = 0    -- Others++parensIf :: Bool -> Doc -> Doc+parensIf True d = parens d+parensIf False d = d++------------------------------++pprint :: Ppr a => a -> String+pprint x = render $ to_HPJ_Doc $ ppr x++class Ppr a where+    ppr :: a -> Doc+    ppr_list :: [a] -> Doc+    ppr_list = vcat . map ppr++instance Ppr a => Ppr [a] where+    ppr x = ppr_list x++------------------------------+instance Ppr Name where+    ppr v = pprName v++------------------------------+instance Ppr Info where+    ppr (TyConI d)     = ppr d+    ppr (ClassI d is)  = ppr d $$ vcat (map ppr is)+    ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)+    ppr (PrimTyConI name arity is_unlifted)+      = text "Primitive"+        <+> (if is_unlifted then text "unlifted" else empty)+        <+> text "type constructor" <+> quotes (ppr name)+        <+> parens (text "arity" <+> int arity)+    ppr (ClassOpI v ty cls)+      = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty+    ppr (DataConI v ty tc)+      = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty+    ppr (PatSynI nm ty) = pprPatSynSig nm ty+    ppr (TyVarI v ty)+      = text "Type variable" <+> ppr v <+> equals <+> ppr ty+    ppr (VarI v ty mb_d)+      = vcat [ppr_sig v ty,+              case mb_d of { Nothing -> empty; Just d -> ppr d }]++ppr_sig :: Name -> Type -> Doc+ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty++pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc+pprFixity _ f _ | f == defaultFixity = empty+pprFixity v (Fixity i d) ns_spec+  = ppr_fix d <+> int i <+> pprNamespaceSpecifier ns_spec <+> pprName' Infix v+    where ppr_fix InfixR = text "infixr"+          ppr_fix InfixL = text "infixl"+          ppr_fix InfixN = text "infix"++pprNamespaceSpecifier :: NamespaceSpecifier -> Doc+pprNamespaceSpecifier NoNamespaceSpecifier = empty+pprNamespaceSpecifier TypeNamespaceSpecifier = text "type"+pprNamespaceSpecifier DataNamespaceSpecifier = text "data"++-- | Pretty prints a pattern synonym type signature+pprPatSynSig :: Name -> PatSynType -> Doc+pprPatSynSig nm ty+  = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty++-- | Pretty prints a pattern synonym's type; follows the usual+-- conventions to print a pattern synonym type compactly, yet+-- unambiguously. See the note on 'PatSynType' and the section on+-- pattern synonyms in the GHC user's guide for more information.+pprPatSynType :: PatSynType -> Doc+pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))+  | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')+  | null uniTys, null reqs  = noreqs <+> ppr ty'+  | null reqs               = pprForallBndrs uniTys <+> noreqs <+> ppr ty'+  | otherwise               = ppr ty+  where noreqs = text "() =>"+        pprForallBndrs tvs = text "forall" <+> hsep (map ppr tvs) <+> text "."+pprPatSynType ty            = ppr ty++------------------------------+instance Ppr Module where+  ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)++instance Ppr ModuleInfo where+  ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)++------------------------------+instance Ppr Exp where+    ppr = pprExp noPrec++pprPrefixOcc :: Name -> Doc+-- Print operators with parens around them+pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)++isSymOcc :: Name -> Bool+isSymOcc n+  = case nameBase n of+      []    -> True  -- Empty name; weird+      (c:_) -> isVarSymChar c+                   -- c.f. isVarSymChar in GHC itself++pprInfixExp :: Exp -> Doc+pprInfixExp (VarE v) = pprName' Infix v+pprInfixExp (ConE v) = pprName' Infix v+pprInfixExp (UnboundVarE v) = pprName' Infix v+-- This case will only ever be reached in exceptional circumstances.+-- For example, when printing an error message in case of a malformed expression.+pprInfixExp e = text "`" <> ppr e <> text "`"++pprExp :: Precedence -> Exp -> Doc+pprExp _ (VarE v)     = pprName' Applied v+pprExp _ (ConE c)     = pprName' Applied c+pprExp i (LitE l)     = pprLit i l+pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1+                                              <+> pprExp appPrec e2+pprExp i (AppTypeE e t)+ = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t+pprExp _ (ParensE e)  = parens (pprExp noPrec e)+pprExp i (UInfixE e1 op e2)+ = parensIf (i > unopPrec) $ pprExp unopPrec e1+                         <+> pprInfixExp op+                         <+> pprExp unopPrec e2+pprExp i (InfixE (Just e1) op (Just e2))+ = parensIf (i >= opPrec) $ pprExp opPrec e1+                        <+> pprInfixExp op+                        <+> pprExp opPrec e2+pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1+                                    <+> pprInfixExp op+                                    <+> pprMaybeExp noPrec me2+pprExp i (LamE [] e) = pprExp i e -- #13856+pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)+                                           <+> text "->" <+> ppr e+pprExp i (LamCaseE ms)+  = parensIf (i > noPrec) $ text "\\case" $$ braces (semiSep ms)+pprExp i (LamCasesE ms)+  = parensIf (i > noPrec) $ text "\\cases" $$ braces (semi_sep ms)+  where semi_sep = sep . punctuate semi . map (pprClause False)+pprExp i (TupE es)+  | [Just e] <- es+  = pprExp i (ConE (tupleDataName 1) `AppE` e)+  | otherwise+  = parens (commaSepWith (pprMaybeExp noPrec) es)+pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es)+pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity+-- Nesting in Cond is to avoid potential problems in do statements+pprExp i (CondE guard true false)+ = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,+                       nest 1 $ text "then" <+> ppr true,+                       nest 1 $ text "else" <+> ppr false]+pprExp i (MultiIfE alts)+  = parensIf (i > noPrec) $ vcat $+      case alts of+        []            -> [text "if {}"]+        (alt : alts') -> text "if" <+> pprGuarded arrow alt+                         : map (nest 3 . pprGuarded arrow) alts'+pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_+                                             $$ text " in" <+> ppr e+  where+    pprDecs []  = empty+    pprDecs [d] = ppr d+    pprDecs ds  = braces (semiSep ds)++pprExp i (CaseE e ms)+ = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"+                        $$ braces (semiSep ms)+pprExp i (DoE m ss_) = parensIf (i > noPrec) $+    pprQualifier m <> text "do" <+> pprStms ss_+  where+    pprQualifier Nothing = empty+    pprQualifier (Just modName) = text (modString modName) <> char '.'+    pprStms []  = empty+    pprStms [s] = ppr s+    pprStms ss  = braces (semiSep ss)+pprExp i (MDoE m ss_) = parensIf (i > noPrec) $+    pprQualifier m <> text "mdo" <+> pprStms ss_+  where+    pprQualifier Nothing = empty+    pprQualifier (Just modName) = text (modString modName) <> char '.'+    pprStms []  = empty+    pprStms [s] = ppr s+    pprStms ss  = braces (semiSep ss)++pprExp _ (CompE []) = text "<<Empty CompExp>>"+-- This will probably break with fixity declarations - would need a ';'+pprExp _ (CompE ss) =+    if null ss'+       -- If there are no statements in a list comprehension besides the last+       -- one, we simply treat it like a normal list.+       then text "[" <> ppr s <> text "]"+       else text "[" <> ppr s+        <+> bar+        <+> commaSep ss'+         <> text "]"+  where s = last ss+        ss' = init ss+pprExp _ (ArithSeqE d) = ppr d+pprExp _ (ListE es) = brackets (commaSep es)+pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e+                                          <+> dcolon <+> pprType sigPrec t+pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)+pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)+pprExp i (StaticE e) = parensIf (i >= appPrec) $+                         text "static"<+> pprExp appPrec e+pprExp _ (UnboundVarE v) = pprName' Applied v+pprExp _ (LabelE s) = text "#" <> text s+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+pprExp i (TypeE t) = parensIf (i > noPrec) $ text "type" <+> ppr t+pprExp i (ForallVisE tvars body) =+  parensIf (i >= funPrec) $ sep [pprForallVis tvars [], pprExp qualPrec body]+pprExp i (ForallE tvars body) =+  parensIf (i >= funPrec) $ sep [pprForall tvars [], pprExp qualPrec body]+pprExp i (ConstrainedE ctx body) =+  parensIf (i >= funPrec) $ sep [pprCtxWith pprExp ctx, pprExp qualPrec body]++pprFields :: [(Name,Exp)] -> Doc+pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)++pprMaybeExp :: Precedence -> Maybe Exp -> Doc+pprMaybeExp _ Nothing = empty+pprMaybeExp i (Just e) = pprExp i e++------------------------------+instance Ppr Stmt where+    ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e+    ppr (LetS ds) = text "let" <+> (braces (semiSep ds))+    ppr (NoBindS e) = ppr e+    ppr (ParS sss) = sep $ punctuate bar+                         $ map commaSep sss+    ppr (RecS ss) = text "rec" <+> (braces (semiSep ss))++------------------------------+instance Ppr Match where+    ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs+                        $$ where_clause ds++pprMatchPat :: Pat -> Doc+-- Everything except pattern signatures bind more tightly than (->)+pprMatchPat p@(SigP {}) = parens (ppr p)+pprMatchPat p           = ppr p++------------------------------+pprGuarded :: Doc -> (Guard, Exp) -> Doc+pprGuarded eqDoc (guard, expr) = case guard of+  NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr+  PatG    stmts     -> bar <+> vcat (punctuate comma $ map ppr stmts) $$+                         nest nestDepth (eqDoc <+> ppr expr)++------------------------------+pprBody :: Bool -> Body -> Doc+pprBody eq body = case body of+    GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs+    NormalB  e  -> eqDoc <+> ppr e+  where eqDoc | eq        = equals+              | otherwise = arrow++------------------------------+pprClause :: Bool -> Clause -> Doc+pprClause eqDoc (Clause ps rhs ds)+  = hsep (map (pprPat appPrec) ps) <+> pprBody eqDoc rhs+    $$ where_clause ds++------------------------------+instance Ppr Lit where+  ppr = pprLit noPrec++pprLit :: Precedence -> Lit -> Doc+pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)+                                    (integer x <> char '#')+pprLit _ (WordPrimL x)    = integer x <> text "##"+pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)+                                    (float (fromRational x) <> char '#')+pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)+                                    (double (fromRational x) <> text "##")+pprLit i (IntegerL x)    = parensIf (i > noPrec && x < 0) (integer x)+pprLit _ (CharL c)       = text (show c)+pprLit _ (CharPrimL c)   = text (show c) <> char '#'+pprLit _ (StringL s)     = pprString s+pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'+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+  -- or can't be represented as Double, show as fraction+  = parensIf (i > noPrec) $+    integer (numerator rat) <+> char '/' <+> integer (denominator rat)+  | 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)+  | 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 = 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+        withoutFactor _ 0 = 0+        withoutFactor p n+          | (n', 0) <- divMod n p = withoutFactor p n'+          | otherwise = n+        -- | Expects the argument 0 <= x < 1+        decimals :: Rational -> Doc+        decimals x+          | x == 0 = empty+          | otherwise = integer n <> decimals d+          where (n, d) = properFraction (x * 10)++bytesToString :: [Word8] -> String+bytesToString = map (chr . fromIntegral)++pprString :: String -> Doc+-- Print newlines as newlines with Haskell string escape notation,+-- not as '\n'.  For other non-printables use regular escape notation.+pprString s = vcat (map text (showMultiLineString s))++------------------------------+instance Ppr Pat where+    ppr = pprPat noPrec++pprPat :: Precedence -> Pat -> Doc+pprPat i (LitP l)     = pprLit i l+pprPat _ (VarP v)     = pprName' Applied v+pprPat i (TupP ps)+  | [_] <- ps+  = pprPat i (ConP (tupleDataName 1) [] ps)+  | otherwise+  = parens (commaSep ps)+pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)+pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity+pprPat i (ConP s ts ps)  = parensIf (i >= appPrec) $+      pprName' Applied s+  <+> sep (map (\t -> char '@' <> pprParendType t) ts)+  <+> sep (map (pprPat appPrec) ps)+pprPat _ (ParensP p)  = parens $ pprPat noPrec p+pprPat i (UInfixP p1 n p2)+                      = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>+                                                 pprName' Infix n   <+>+                                                 pprPat unopPrec p2)+pprPat i (InfixP p1 n p2)+                      = parensIf (i >= opPrec) (pprPat opPrec p1 <+>+                                                pprName' Infix n <+>+                                                pprPat opPrec p2)+pprPat i (TildeP p)   = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p+pprPat i (BangP p)    = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p+pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"+                                                      <> pprPat appPrec p+pprPat _ WildP        = text "_"+pprPat _ (RecP nm fs)+ = parens $     pprName' Applied nm+            <+> braces (sep $ punctuate comma $+                        map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs)+pprPat _ (ListP ps) = brackets (commaSep ps)+pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t+pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p+pprPat _ (TypeP t) = parens $ text "type" <+> ppr t+pprPat _ (InvisP t) = parens $ text "@" <+> ppr t+pprPat _ (OrP t) = parens $ semiSep (NE.toList t)++------------------------------+instance Ppr Dec where+    ppr = ppr_dec True++ppr_dec :: Bool     -- ^ declaration on the toplevel?+        -> Dec+        -> Doc+ppr_dec isTop (FunD f cs)   = layout $ map (\c -> pprPrefixOcc f <+> ppr c) cs+  where+    layout :: [Doc] -> Doc+    layout = if isTop then vcat else semiSepWith id+ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r+                          $$ where_clause ds+ppr_dec _ (TySynD t xs rhs)+  = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs+ppr_dec isTop (DataD ctxt t xs ksig cs decs)+  = ppr_data isTop empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs+ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)+  = ppr_newtype isTop empty ctxt (Just t) (sep (map ppr xs)) ksig c decs+ppr_dec isTop (TypeDataD t xs ksig cs)+  = ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs []+ppr_dec _  (ClassD ctxt c xs fds ds)+  = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds+    $$ where_clause ds+ppr_dec _ (InstanceD o ctxt i ds) =+        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i+                                  $$ where_clause ds+ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t+ppr_dec _ (KiSigD f k)  = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k+ppr_dec _ (ForeignD f)  = ppr f+ppr_dec _ (InfixD fx ns_spec n) = pprFixity n fx ns_spec+ppr_dec _ (DefaultD tys) =+        text "default" <+> parens (sep $ punctuate comma $ map ppr tys)+ppr_dec _ (PragmaD p)   = ppr p+ppr_dec isTop (DataFamilyD tc tvs kind)+  = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind+  where+    maybeFamily | isTop     = text "family"+                | otherwise = empty+    maybeKind | (Just k') <- kind = dcolon <+> ppr k'+              | otherwise = empty+ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)+  = ppr_data isTop (maybeInst <+> ppr_bndrs bndrs)+             ctxt Nothing (ppr ty) ksig cs decs+  where+    maybeInst | isTop     = text "instance"+              | otherwise = empty+ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)+  = ppr_newtype isTop (maybeInst <+> ppr_bndrs bndrs)+                ctxt Nothing (ppr ty) ksig c decs+  where+    maybeInst | isTop     = text "instance"+              | otherwise = empty+ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs))+  = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs)+              Nothing (ppr ty) rhs+  where+    maybeInst | isTop     = text "instance"+              | otherwise = empty+ppr_dec isTop (OpenTypeFamilyD tfhead)+  = text "type" <+> maybeFamily <+> ppr_tf_head tfhead+  where+    maybeFamily | isTop     = text "family"+                | otherwise = empty+ppr_dec _ (ClosedTypeFamilyD tfhead eqns)+  = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")+      nestDepth (vcat (map ppr_eqn eqns))+  where+    ppr_eqn (TySynEqn mb_bndrs lhs rhs)+      = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs+ppr_dec _ (RoleAnnotD name roles)+  = hsep [ text "type role", pprName' Applied name ] <+> hsep (map ppr roles)+ppr_dec _ (StandaloneDerivD ds cxt ty)+  = hsep [ text "deriving"+         , maybe empty ppr_deriv_strategy ds+         , text "instance"+         , pprCxt cxt+         , ppr ty ]+ppr_dec _ (DefaultSigD n ty)+  = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]+ppr_dec _ (PatSynD name args dir pat)+  = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS+  where+    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2+                | otherwise                 = pprName' Applied name <+> ppr args+    pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")+                                              nestDepth+                                              (vcat $ (pprName' Applied name <+>) . ppr <$> cls)+                | otherwise            = ppr pat+ppr_dec _ (PatSynSigD name ty)+  = pprPatSynSig name ty+ppr_dec _ (ImplicitParamBindD n e)+  = hsep [text ('?' : n), text "=", ppr e]++ppr_deriv_strategy :: DerivStrategy -> Doc+ppr_deriv_strategy ds =+  case ds of+    StockStrategy    -> text "stock"+    AnyclassStrategy -> text "anyclass"+    NewtypeStrategy  -> text "newtype"+    ViaStrategy ty   -> text "via" <+> pprParendType ty++ppr_overlap :: Overlap -> Doc+ppr_overlap o = text $+  case o of+    Overlaps      -> "{-# OVERLAPS #-}"+    Overlappable  -> "{-# OVERLAPPABLE #-}"+    Overlapping   -> "{-# OVERLAPPING #-}"+    Incoherent    -> "{-# INCOHERENT #-}"++ppr_data :: Bool     -- ^ declaration on the toplevel?+         -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]+         -> Doc+ppr_data = ppr_typedef "data"++ppr_newtype :: Bool     -- ^ declaration on the toplevel?+            -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]+            -> Doc+ppr_newtype isTop maybeInst ctxt t argsDoc ksig c decs+  = ppr_typedef "newtype" isTop maybeInst ctxt t argsDoc ksig [c] decs++ppr_type_data :: Bool     -- ^ declaration on the toplevel?+              -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]+              -> Doc+ppr_type_data = ppr_typedef "type data"++ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc+ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs+  = sep [text data_or_newtype <+> maybeInst+            <+> pprCxt ctxt+            <+> case t of+                 Just n -> pprName' Applied n <+> argsDoc+                 Nothing -> argsDoc+            <+> ksigDoc <+> maybeWhere,+         nest nestDepth (layout (pref $ map ppr cs)),+         if null decs+           then empty+           else nest nestDepth+              $ vcat $ map ppr_deriv_clause decs]+  where+    pref :: [Doc] -> [Doc]+    pref xs | isGadtDecl = xs+    pref []              = []      -- No constructors; can't happen in H98+    pref (d:ds)          = (char '=' <+> d):map (bar <+>) ds++    layout :: [Doc] -> Doc+    layout | isGadtDecl && not isTop = braces . semiSepWith id+           | otherwise = vcat++    maybeWhere :: Doc+    maybeWhere | isGadtDecl = text "where"+               | otherwise  = empty++    isGadtDecl :: Bool+    isGadtDecl = not (null cs) && all isGadtCon cs+        where isGadtCon (GadtC _ _ _   ) = True+              isGadtCon (RecGadtC _ _ _) = True+              isGadtCon (ForallC _ _ x ) = isGadtCon x+              isGadtCon  _               = False++    ksigDoc = case ksig of+                Nothing -> empty+                Just k  -> dcolon <+> ppr k+++ppr_deriv_clause :: DerivClause -> Doc+ppr_deriv_clause (DerivClause ds ctxt)+  = text "deriving" <+> pp_strat_before+                    <+> ppr_cxt_preds appPrec ctxt+                    <+> pp_strat_after+  where+    -- @via@ is unique in that in comes /after/ the class being derived,+    -- so we must special-case it.+    (pp_strat_before, pp_strat_after) =+      case ds of+        Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via)+        _                        -> (maybe empty ppr_deriv_strategy ds, empty)++ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc+ppr_tySyn maybeInst t argsDoc rhs+  = text "type" <+> maybeInst+    <+> case t of+         Just n -> pprName' Applied n <+> argsDoc+         Nothing -> argsDoc+    <+> text "=" <+> ppr rhs++ppr_tf_head :: TypeFamilyHead -> Doc+ppr_tf_head (TypeFamilyHead tc tvs res inj)+  = pprName' Applied tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj+  where+    maybeInj | (Just inj') <- inj = ppr inj'+             | otherwise          = empty++ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc+ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."+ppr_bndrs Nothing = empty++------------------------------+instance Ppr FunDep where+    ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)+    ppr_list [] = empty+    ppr_list xs = bar <+> commaSep xs++------------------------------+instance Ppr FamilyResultSig where+    ppr NoSig           = empty+    ppr (KindSig k)     = dcolon <+> ppr k+    ppr (TyVarSig bndr) = text "=" <+> ppr bndr++------------------------------+instance Ppr InjectivityAnn where+    ppr (InjectivityAnn lhs rhs) =+        bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)++------------------------------+instance Ppr Foreign where+    ppr (ImportF callconv safety impent as typ)+       = text "foreign import"+     <+> showtextl callconv+     <+> showtextl safety+     <+> text (show impent)+     <+> pprName' Applied as+     <+> dcolon <+> ppr typ+    ppr (ExportF callconv expent as typ)+        = text "foreign export"+      <+> showtextl callconv+      <+> text (show expent)+      <+> pprName' Applied as+      <+> dcolon <+> ppr typ++------------------------------+instance Ppr Pragma where+    ppr (InlineP n inline rm phases)+       = text "{-#"+     <+> ppr inline+     <+> ppr rm+     <+> ppr phases+     <+> pprName' Applied n+     <+> text "#-}"+    ppr (OpaqueP n)+       = text "{-# OPAQUE" <+> pprName' Applied n <+> text "#-}"+    ppr (SpecialiseP n ty inline phases)+       =   text "{-# SPECIALISE"+       <+> maybe empty ppr inline+       <+> ppr phases+       <+> sep [ pprName' Applied n <+> dcolon+               , nest 2 $ ppr ty ]+       <+> text "#-}"+    ppr (SpecialiseInstP inst)+       = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"+    ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)+       = sep [ text "{-# RULES" <+> pprString n <+> ppr phases+             , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs+                                               <+> ppr lhs+             , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]+      where ppr_ty_forall Nothing      = empty+            ppr_ty_forall (Just bndrs) = text "forall"+                                         <+> fsep (map ppr bndrs)+                                         <+> char '.'+            ppr_tm_forall Nothing | null tm_bndrs = empty+            ppr_tm_forall _ = text "forall"+                              <+> fsep (map ppr tm_bndrs)+                              <+> char '.'+    ppr (AnnP tgt expr)+       = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"+      where target1 ModuleAnnotation    = text "module"+            target1 (TypeAnnotation t)  = text "type" <+> pprName' Applied t+            target1 (ValueAnnotation v) = pprName' Applied v+    ppr (LineP line file)+       = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"+    ppr (CompleteP cls mty)+       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)+                <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"+    ppr (SCCP nm str)+       = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}"++------------------------------+instance Ppr Inline where+    ppr NoInline  = text "NOINLINE"+    ppr Inline    = text "INLINE"+    ppr Inlinable = text "INLINABLE"++------------------------------+instance Ppr RuleMatch where+    ppr ConLike = text "CONLIKE"+    ppr FunLike = empty++------------------------------+instance Ppr Phases where+    ppr AllPhases       = empty+    ppr (FromPhase i)   = brackets $ int i+    ppr (BeforePhase i) = brackets $ char '~' <> int i++------------------------------+instance Ppr RuleBndr where+    ppr (RuleVar n)         = ppr n+    ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty++------------------------------+instance Ppr Clause where+    ppr = pprClause True++------------------------------+instance Ppr Con where+    ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts)++    ppr (RecC c vsts)+        = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))++    ppr (InfixC st1 c st2) = pprBangType st1+                         <+> pprName' Infix c+                         <+> pprBangType st2++    ppr (ForallC ns ctxt (GadtC cs sts ty))+        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt+      <+> pprGadtRHS sts ty++    ppr (ForallC ns ctxt (RecGadtC cs vsts ty))+        = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt+      <+> pprRecFields vsts ty++    ppr (ForallC ns ctxt con)+        = pprForall ns ctxt <+> ppr con++    ppr (GadtC cs sts ty)+        = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty++    ppr (RecGadtC cs vsts ty)+        = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty++instance Ppr PatSynDir where+  ppr Unidir        = text "<-"+  ppr ImplBidir     = text "="+  ppr (ExplBidir _) = text "<-"+    -- the ExplBidir's clauses are pretty printed together with the+    -- entire pattern synonym; so only print the direction here.++instance Ppr PatSynArgs where+  ppr (PrefixPatSyn args) = sep $ map ppr args+  ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2+  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map (pprName' Applied) sels))++commaSepApplied :: [Name] -> Doc+commaSepApplied = commaSepWith (pprName' Applied)++pprForall :: [TyVarBndr Specificity] -> Cxt -> Doc+pprForall = pprForall' ForallInvis++pprForallVis :: [TyVarBndr ()] -> Cxt -> Doc+pprForallVis = pprForall' ForallVis++pprForall' :: PprFlag flag => ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc+pprForall' fvf tvs cxt+  -- even in the case without any tvs, there could be a non-empty+  -- context cxt (e.g., in the case of pattern synonyms, where there+  -- are multiple forall binders and contexts).+  | [] <- tvs = pprCxt cxt+  | otherwise = text "forall" <+> hsep (map ppr tvs)+                              <+> separator <+> pprCxt cxt+  where+    separator = case fvf of+                  ForallVis   -> text "->"+                  ForallInvis -> char '.'++pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc+pprRecFields vsts ty+    = braces (sep (punctuate comma $ map pprVarBangType vsts))+  <+> arrow <+> ppr ty++pprGadtRHS :: [(Strict, Type)] -> Type -> Doc+pprGadtRHS [] ty+    = ppr ty+pprGadtRHS sts ty+    = sep (punctuate (space <> arrow) (map pprBangType sts))+  <+> arrow <+> ppr ty++------------------------------+pprVarBangType :: VarBangType -> Doc+-- Slight infelicity: with print non-atomic type with parens+pprVarBangType (v, bang, t) = pprName' Applied v <+> dcolon <+> pprBangType (bang, t)++------------------------------+pprBangType :: BangType -> Doc+-- Make sure we print+--+-- Con {-# UNPACK #-} a+--+-- rather than+--+-- Con {-# UNPACK #-}a+--+-- when there's no strictness annotation. If there is a strictness annotation,+-- it's okay to not put a space between it and the type.+pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t+pprBangType (bt, t) = ppr bt <> pprParendType t++------------------------------+instance Ppr Bang where+    ppr (Bang su ss) = ppr su <+> ppr ss++------------------------------+instance Ppr SourceUnpackedness where+    ppr NoSourceUnpackedness = empty+    ppr SourceNoUnpack       = text "{-# NOUNPACK #-}"+    ppr SourceUnpack         = text "{-# UNPACK #-}"++------------------------------+instance Ppr SourceStrictness where+    ppr NoSourceStrictness = empty+    ppr SourceLazy         = char '~'+    ppr SourceStrict       = char '!'++------------------------------+instance Ppr DecidedStrictness where+    ppr DecidedLazy   = empty+    ppr DecidedStrict = char '!'+    ppr DecidedUnpack = text "{-# UNPACK #-} !"++------------------------------+{-# DEPRECATED pprVarStrictType+               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}+pprVarStrictType :: (Name, Strict, Type) -> Doc+pprVarStrictType = pprVarBangType++------------------------------+{-# DEPRECATED pprStrictType+               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}+pprStrictType :: (Strict, Type) -> Doc+pprStrictType = pprBangType++------------------------------+pprType :: Precedence -> Type -> Doc+pprType _ (VarT v)               = pprName' Applied v+-- `Applied` is used here instead of `ppr` because of infix names (#13887)+pprType _ (ConT c)               = pprName' Applied c+pprType _ (TupleT 0)             = text "()"+pprType p (TupleT 1)             = pprType p (ConT (tupleTypeName 1))+pprType _ (TupleT n)             = parens (hcat (replicate (n-1) comma))+pprType _ (UnboxedTupleT n)      = hashParens $ hcat $ replicate (n-1) comma+pprType _ (UnboxedSumT arity)    = hashParens $ hsep $ replicate (arity-1) bar+pprType _ ArrowT                 = parens (text "->")+pprType _ MulArrowT              = text "FUN"+pprType _ ListT                  = text "[]"+pprType _ (LitT l)               = pprTyLit l+pprType _ (PromotedT c)          = text "'" <> pprName' Applied c+pprType _ (PromotedTupleT 0)     = text "'()"+pprType p (PromotedTupleT 1)     = pprType p (PromotedT (tupleDataName 1))+pprType _ (PromotedTupleT n)     = quoteParens (hcat (replicate (n-1) comma))+pprType _ PromotedNilT           = text "'[]"+pprType _ PromotedConsT          = text "'(:)"+pprType _ StarT                  = char '*'+pprType _ ConstraintT            = text "Constraint"+pprType _ (SigT ty k)            = parens (ppr ty <+> text "::" <+> ppr k)+pprType _ WildCardT              = char '_'+pprType p t@(InfixT {})          = pprInfixT p t+pprType p t@(UInfixT {})         = pprInfixT p t+pprType p t@(PromotedInfixT {})  = pprInfixT p t+pprType p t@(PromotedUInfixT {}) = pprInfixT p t+pprType _ (ParensT t)            = parens (pprType noPrec t)+pprType p (ImplicitParamT n ty) =+  parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty+pprType _ EqualityT              = text "(~)"+pprType p (ForallT tvars ctxt ty) =+  parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty]+pprType p (ForallVisT tvars ty) =+  parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty]+pprType p t@AppT{}               = pprTyApp p (split t)+pprType p t@AppKindT{}           = pprTyApp p (split t)++------------------------------+pprParendType :: Type -> Doc+pprParendType = pprType appPrec++pprInfixT :: Precedence -> Type -> Doc+pprInfixT p = \case+  InfixT x n y          -> with x n y ""  opPrec+  UInfixT x n y         -> with x n y ""  unopPrec+  PromotedInfixT x n y  -> with x n y "'" opPrec+  PromotedUInfixT x n y -> with x n y "'" unopPrec+  t                     -> pprParendType t+  where+    with x n y prefix p' =+      parensIf+        (p >= p')+        (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y)++instance Ppr Type where+    ppr = pprType noPrec+instance Ppr TypeArg where+    ppr (TANormal ty) = ppr ty+    ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)++pprParendTypeArg :: TypeArg -> Doc+pprParendTypeArg (TANormal ty) = pprParendType ty+pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)++isStarT :: Type -> Bool+isStarT StarT = True+isStarT _ = False++{- Note [Pretty-printing kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's parser only recognises a kind signature in a type when there are+parens around it.  E.g. the parens are required here:+   f :: (Int :: *)+   type instance F Int = (Bool :: *)+So we always print a SigT with parens (see #10050). -}++pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc+pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])+  | p >= funPrec  = parens (pprTyApp noPrec app)+  | c == oneName  = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2]+  | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]+pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =+  parensIf (p >= funPrec) $+    sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->",+         pprType qualPrec arg2]+pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) =+  parensIf (p >= funPrec) $+    sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]+pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) =+  parensIf (p >= opPrec) $+    sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2]+pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg)+pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args)+pprTyApp _ (TupleT n, args)+ | length args == n, Just args' <- traverse fromTANormal args+ = parens (commaSep args')+pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args)+pprTyApp _ (PromotedTupleT n, args)+ | length args == n, Just args' <- traverse fromTANormal args+ = quoteParens (commaSep args')+pprTyApp _ (UnboxedTupleT n, args)+ | length args == n, Just args' <- traverse fromTANormal args+ = hashParens (commaSep args')+pprTyApp _ (UnboxedSumT n, args)+ | length args == n, Just args' <- traverse fromTANormal args+ = hashParens (sep $ intersperse bar $ map ppr args')+pprTyApp p (fun, args) =+  parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args)++fromTANormal :: TypeArg -> Maybe Type+fromTANormal (TANormal arg) = Just arg+fromTANormal (TyArg _) = Nothing++-- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->).+pprFunArgType :: Type -> Doc+pprFunArgType = pprType funPrec++data ForallVisFlag = ForallVis   -- forall a -> {...}+                   | ForallInvis -- forall a.   {...}+  deriving Show++data TypeArg = TANormal Type+             | TyArg Kind++split :: Type -> (Type, [TypeArg])    -- Split into function and args+split t = go t []+    where go (AppT t1 t2) args = go t1 (TANormal t2:args)+          go (AppKindT ty ki) args = go ty (TyArg ki:args)+          go ty           args = (ty, args)++pprTyLit :: TyLit -> Doc+pprTyLit (NumTyLit n) = integer n+pprTyLit (StrTyLit s) = text (show s)+pprTyLit (CharTyLit c) = text (show c)++instance Ppr TyLit where+  ppr = pprTyLit++------------------------------+class PprFlag flag where+    pprTyVarBndr :: (TyVarBndr flag) -> Doc++instance PprFlag () where+    pprTyVarBndr (PlainTV nm ())    = ppr nm+    pprTyVarBndr (KindedTV nm () k) = parens (ppr nm <+> dcolon <+> ppr k)++instance PprFlag Specificity where+    pprTyVarBndr (PlainTV nm SpecifiedSpec)    = ppr nm+    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++instance Ppr Role where+    ppr NominalR          = text "nominal"+    ppr RepresentationalR = text "representational"+    ppr PhantomR          = text "phantom"+    ppr InferR            = text "_"++------------------------------+pprCtxWith :: Ppr a => (Precedence -> a -> Doc) -> [a] -> Doc+pprCtxWith _ [] = empty+pprCtxWith ppr_fun ts = ppr_ctx_preds_with ppr_fun funPrec ts <+> text "=>"++pprCxt :: Cxt -> Doc+pprCxt = pprCtxWith pprType++ppr_ctx_preds_with :: Ppr a => (Precedence -> a -> Doc) -> Precedence -> [a] -> Doc+ppr_ctx_preds_with _ _ [] = text "()"+ppr_ctx_preds_with f p [t] = f p t+ppr_ctx_preds_with _ _ ts = parens (commaSep ts)++ppr_cxt_preds :: Precedence -> Cxt -> Doc+ppr_cxt_preds = ppr_ctx_preds_with pprType++------------------------------+instance Ppr Range where+    ppr = brackets . pprRange+        where pprRange :: Range -> Doc+              pprRange (FromR e) = ppr e <+> text ".."+              pprRange (FromThenR e1 e2) = ppr e1 <> text ","+                                           <+> ppr e2 <+> text ".."+              pprRange (FromToR e1 e2) = ppr e1 <+> text ".." <+> ppr e2+              pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","+                                             <+> ppr e2 <+> text ".."+                                             <+> ppr e3++------------------------------+where_clause :: [Dec] -> Doc+where_clause [] = empty+where_clause ds = nest nestDepth $ text "where" <+> braces (semiSepWith (ppr_dec False) ds)++showtextl :: Show a => a -> Doc+showtextl = text . map toLower . show++hashParens :: Doc -> Doc+hashParens d = text "(# " <> d <> text " #)"++quoteParens :: Doc -> Doc+quoteParens d = text "'(" <> d <> text ")"++-----------------------------+instance Ppr Loc where+  ppr (Loc { loc_module = md+           , loc_package = pkg+           , loc_start = (start_ln, start_col)+           , loc_end = (end_ln, end_col) })+    = hcat [ text pkg, colon, text md, colon+           , parens $ int start_ln <> comma <> int start_col+           , text "-"+           , parens $ int end_ln <> comma <> int end_col ]++-- Takes a separator and a pretty-printing function and prints a list of things+-- separated by the separator followed by space.+sepWith :: Doc -> (a -> Doc) -> [a] -> Doc+sepWith sepDoc pprFun = sep . punctuate sepDoc . map pprFun++-- Takes a list of printable things and prints them separated by commas followed+-- by space.+commaSep :: Ppr a => [a] -> Doc+commaSep = commaSepWith ppr++-- Takes a list of things and prints them with the given pretty-printing+-- function, separated by commas followed by space.+commaSepWith :: (a -> Doc) -> [a] -> Doc+commaSepWith pprFun = sepWith comma pprFun++-- Takes a list of printable things and prints them separated by semicolons+-- followed by space.+semiSep :: Ppr a => [a] -> Doc+semiSep = sep . punctuate semi . map ppr++-- Takes a list of things and prints them with the given pretty-printing+-- function, separated by semicolons followed by space.+semiSepWith :: (a -> Doc) -> [a] -> Doc+semiSepWith pprFun = sepWith semi pprFun++-- Prints out the series of vertical bars that wraps an expression or pattern+-- used in an unboxed sum.+unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc+unboxedSumBars d alt arity = hashParens $+    bars (alt-1) <> d <> bars (arity - alt)+  where+    bars i = hsep (replicate i bar)++-- Text containing the vertical bar character.+bar :: Doc+bar = char '|'

@@ -0,0 +1,226 @@+{-# LANGUAGE FlexibleInstances, Safe #-}++-- | Monadic front-end to Text.PrettyPrint++module GHC.Boot.TH.PprLib (++        -- * The document type+        Doc,            -- Abstract, instance of Show+        PprM,++        -- * Primitive Documents+        empty,+        semi, comma, colon, dcolon, space, equals, arrow,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,++        -- * Converting values into documents+        text, char, ptext,+        int, integer, float, double, rational,++        -- * Wrapping documents in delimiters+        parens, brackets, braces, quotes, doubleQuotes,++        -- * Combining documents+        (<>), (<+>), hcat, hsep,+        ($$), ($+$), vcat,+        sep, cat,+        fsep, fcat,+        nest,+        hang, punctuate,++        -- * Predicates on documents+        isEmpty,++    to_HPJ_Doc, pprName, pprName'+  ) where+++import GHC.Boot.TH.Syntax+    (Uniq, Name(..), showName', NameFlavour(..), NameIs(..))+import qualified Text.PrettyPrint as HPJ+import Control.Monad (liftM, liftM2, ap)+import GHC.Boot.TH.Lib.Map ( Map )+import qualified GHC.Boot.TH.Lib.Map as Map ( lookup, insert, empty )+import Prelude hiding ((<>))++infixl 6 <>+infixl 6 <+>+infixl 5 $$, $+$++-- ---------------------------------------------------------------------------+-- The interface++-- The primitive Doc values++instance Show Doc where+   show d = HPJ.render (to_HPJ_Doc d)++isEmpty :: Doc    -> PprM Bool;  -- ^ Returns 'True' if the document is empty++empty   :: Doc;                 -- ^ An empty document+semi    :: Doc;                 -- ^ A ';' character+comma   :: Doc;                 -- ^ A ',' character+colon   :: Doc;                 -- ^ A ':' character+dcolon  :: Doc;                 -- ^ A "::" string+space   :: Doc;                 -- ^ A space character+equals  :: Doc;                 -- ^ A '=' character+arrow   :: Doc;                 -- ^ A "->" string+lparen  :: Doc;                 -- ^ A '(' character+rparen  :: Doc;                 -- ^ A ')' character+lbrack  :: Doc;                 -- ^ A '[' character+rbrack  :: Doc;                 -- ^ A ']' character+lbrace  :: Doc;                 -- ^ A '{' character+rbrace  :: Doc;                 -- ^ A '}' character++text     :: String   -> Doc+ptext    :: String   -> Doc+char     :: Char     -> Doc+int      :: Int      -> Doc+integer  :: Integer  -> Doc+float    :: Float    -> Doc+double   :: Double   -> Doc+rational :: Rational -> Doc+++parens       :: Doc -> Doc;     -- ^ Wrap document in @(...)@+brackets     :: Doc -> Doc;     -- ^ Wrap document in @[...]@+braces       :: Doc -> Doc;     -- ^ Wrap document in @{...}@+quotes       :: Doc -> Doc;     -- ^ Wrap document in @\'...\'@+doubleQuotes :: Doc -> Doc;     -- ^ Wrap document in @\"...\"@++-- Combining @Doc@ values++(<>)   :: Doc -> Doc -> Doc;     -- ^Beside+hcat   :: [Doc] -> Doc;          -- ^List version of '<>'+(<+>)  :: Doc -> Doc -> Doc;     -- ^Beside, separated by space+hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'++($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no+                                 -- overlap it \"dovetails\" the two+($+$)  :: Doc -> Doc -> Doc;     -- ^Above, without dovetailing.+vcat   :: [Doc] -> Doc;          -- ^List version of '$$'++cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat+sep    :: [Doc] -> Doc;          -- ^ Either hsep or vcat+fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of cat+fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of sep++nest   :: Int -> Doc -> Doc;     -- ^ Nested+++-- GHC-specific ones.++hang :: Doc -> Int -> Doc -> Doc;      -- ^ @hang d1 n d2 = sep [d1, nest n d2]@+punctuate :: Doc -> [Doc] -> [Doc]+   -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@++-- ---------------------------------------------------------------------------+-- The "implementation"++type State = (Map Name Name, Uniq)+data PprM a = PprM { runPprM :: State -> (a, State) }++pprName :: Name -> Doc+pprName = pprName' Alone++pprName' :: NameIs -> Name -> Doc+pprName' ni n@(Name o (NameU _))+ = PprM $ \s@(fm, i)+        -> let (n', s') = case Map.lookup n fm of+                         Just d -> (d, s)+                         Nothing -> let n'' = Name o (NameU i)+                                    in (n'', (Map.insert n n'' fm, i + 1))+           in (HPJ.text $ showName' ni n', s')+pprName' ni n = text $ showName' ni n++{-+instance Show Name where+  show (Name occ (NameU u))    = occString occ ++ "_" ++ show (I# u)+  show (Name occ NameS)        = occString occ+  show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ++data Name = Name OccName NameFlavour++data NameFlavour+  | NameU Int#                  -- A unique local name+-}++to_HPJ_Doc :: Doc -> HPJ.Doc+to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0)++instance Functor PprM where+      fmap = liftM++instance Applicative PprM where+      pure x = PprM $ \s -> (x, s)+      (<*>) = ap++instance Monad PprM where+    m >>= k  = PprM $ \s -> let (x, s') = runPprM m s+                            in runPprM (k x) s'++type Doc = PprM HPJ.Doc++-- The primitive Doc values++isEmpty = liftM HPJ.isEmpty++empty = return HPJ.empty+semi = return HPJ.semi+comma = return HPJ.comma+colon = return HPJ.colon+dcolon = return $ HPJ.text "::"+space = return HPJ.space+equals = return HPJ.equals+arrow = return $ HPJ.text "->"+lparen = return HPJ.lparen+rparen = return HPJ.rparen+lbrack = return HPJ.lbrack+rbrack = return HPJ.rbrack+lbrace = return HPJ.lbrace+rbrace = return HPJ.rbrace++text = return . HPJ.text+ptext = return . HPJ.ptext+char = return . HPJ.char+int = return . HPJ.int+integer = return . HPJ.integer+float = return . HPJ.float+double = return . HPJ.double+rational = return . HPJ.rational+++parens = liftM HPJ.parens+brackets = liftM HPJ.brackets+braces = liftM HPJ.braces+quotes = liftM HPJ.quotes+doubleQuotes = liftM HPJ.doubleQuotes++-- Combining @Doc@ values++(<>) = liftM2 (HPJ.<>)+hcat = liftM HPJ.hcat . sequence+(<+>) = liftM2 (HPJ.<+>)+hsep = liftM HPJ.hsep . sequence++($$) = liftM2 (HPJ.$$)+($+$) = liftM2 (HPJ.$+$)+vcat = liftM HPJ.vcat . sequence++cat  = liftM HPJ.cat . sequence+sep  = liftM HPJ.sep . sequence+fcat = liftM HPJ.fcat . sequence+fsep = liftM HPJ.fsep . sequence++nest n = liftM (HPJ.nest n)++hang d1 n d2 = do d1' <- d1+                  d2' <- d2+                  return (HPJ.hang d1' n d2')++-- punctuate uses the same definition as Text.PrettyPrint+punctuate _ []     = []+punctuate p (d:ds) = go d ds+                   where+                     go d' [] = [d']+                     go d' (e:es) = (d' <> p) : go e es

@@ -0,0 +1,6 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}+module GHC.Boot.TH.Syntax+  (module GHC.Internal.TH.Syntax) where++import GHC.Internal.TH.Syntax

@@ -3,13 +3,13 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal.  name:           ghc-boot-th-version:        9.12.2+version:        9.12.3 license:        BSD3 license-file:   LICENSE category:       GHC maintainer:     ghc-devs@haskell.org bug-reports:    https://gitlab.haskell.org/ghc/ghc/issues/new-synopsis:       Shared functionality between GHC and the @template-haskell@+synopsis:       Shared functionality between GHC and the template-haskell                 library description:    This library contains various bits shared between the @ghc@ and                 @template-haskell@ libraries.@@ -42,9 +42,9 @@      exposed-modules:             GHC.ForeignSrcLang.Type-            GHC.Internal.TH.Lib.Map-            GHC.Internal.TH.Ppr-            GHC.Internal.TH.PprLib+            GHC.Boot.TH.Lib.Map+            GHC.Boot.TH.Ppr+            GHC.Boot.TH.PprLib             GHC.LanguageExtensions.Type             GHC.Lexeme @@ -57,9 +57,11 @@         cpp-options: -DBOOTSTRAP_TH         hs-source-dirs: . ../ghc-internal/src         exposed-modules:+            GHC.Boot.TH.Lib+            GHC.Boot.TH.Syntax+        other-modules:             GHC.Internal.TH.Lib             GHC.Internal.TH.Syntax-        other-modules:             GHC.Internal.ForeignSrcLang             GHC.Internal.LanguageExtensions             GHC.Internal.Lexeme@@ -67,8 +69,8 @@         hs-source-dirs: .         build-depends:             ghc-internal-        reexported-modules:-            GHC.Internal.TH.Lib,-            GHC.Internal.TH.Lift,-            GHC.Internal.TH.Quote,-            GHC.Internal.TH.Syntax+        exposed-modules:+            GHC.Boot.TH.Lib,+            GHC.Boot.TH.Lift,+            GHC.Boot.TH.Quote,+            GHC.Boot.TH.Syntax

@@ -5,7 +5,7 @@ -- ghc-boot.cabal.  name:           ghc-boot-version:        9.12.2+version:        9.12.3 license:        BSD-3-Clause license-file:   LICENSE category:       GHC@@ -94,10 +94,10 @@      if flag(bootstrap)       build-depends:-              ghc-boot-th-next    == 9.12.2+              ghc-boot-th-next    == 9.12.3     else       build-depends:-              ghc-boot-th         == 9.12.2+              ghc-boot-th         == 9.12.3      if !os(windows)         build-depends:

@@ -1,8 +1,11 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module GHC.Exts.Heap.InfoTable.Types     ( StgInfoTable(..)     , EntryFunPtr-    , HalfWord+    , HalfWord(..)     , ItblCodes     ) where @@ -18,12 +21,15 @@ #include "ghcautoconf.h" -- Ultra-minimalist version specially for constructors #if SIZEOF_VOID_P == 8-type HalfWord = Word32+type HalfWord' = Word32 #elif SIZEOF_VOID_P == 4-type HalfWord = Word16+type HalfWord' = Word16 #else #error Unknown SIZEOF_VOID_P #endif++newtype HalfWord = HalfWord HalfWord'+    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)  type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) 

@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.12.2+version:        9.12.3 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org@@ -28,7 +28,7 @@                   , containers       >= 0.6.2.1 && < 0.8    if impl(ghc >= 9.9)-    build-depends:  ghc-internal     >= 9.900 && < 9.1202.99999+    build-depends:  ghc-internal     >= 9.900 && < 9.1203.99999    ghc-options:      -Wall   if !os(ghcjs)

@@ -56,7 +56,7 @@ import Foreign import GHC.Generics import GHC.Stack.CCS-import qualified GHC.Internal.TH.Syntax        as TH+import qualified GHC.Boot.TH.Syntax        as TH import System.Exit import System.IO import System.IO.Error@@ -498,12 +498,16 @@   put = put . castFunPtrToPtr   get = castPtrToFunPtr <$> get +instance Binary Heap.HalfWord where+  put x = put (fromIntegral x :: Word32)+  get = fromIntegral <$> (get :: Get Word32)+ -- Binary instances to support the GetClosure message #ifndef MIN_VERSION_ghc_heap #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \   (major1) == 9 && (major2) <  12 || \-  (major1) == 9 && (major2) == 12 && (minor) <= 2)+  (major1) == 9 && (major2) == 12 && (minor) <= 3) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo

@@ -12,7 +12,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import GHC.Serialized-import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Boot.TH.Syntax as TH -- Put these in a separate module because they take ages to compile  instance Binary TH.Loc

@@ -2,7 +2,7 @@ -- ../../configure.  Make sure you are editing ghci.cabal.in, not ghci.cabal.  name:           ghci-version:        9.12.2+version:        9.12.3 license:        BSD3 license-file:   LICENSE category:       GHC@@ -85,7 +85,7 @@         rts,         array            == 0.5.*,         base             >= 4.8 && < 4.22,-        -- ghc-internal     == 9.1202.*+        -- ghc-internal     == 9.1203.*         -- TODO: Use GHC.Internal.Desugar and GHC.Internal.Base from         -- ghc-internal instead of ignoring the deprecation warning in GHCi.TH         -- and GHCi.CreateBCO when we require ghc-internal of the bootstrap@@ -96,19 +96,19 @@         containers       >= 0.5 && < 0.8,         deepseq          >= 1.4 && < 1.6,         filepath         >= 1.4 && < 1.6,-        ghc-boot         == 9.12.2,-        ghc-heap         == 9.12.2,+        ghc-boot         == 9.12.3,+        ghc-heap         == 9.12.3,         transformers     >= 0.5 && < 0.7      if flag(bootstrap)       build-depends:-            ghc-boot-th-next  == 9.12.2+            ghc-boot-th-next  == 9.12.3     else       build-depends:-            ghc-boot-th       == 9.12.2+            ghc-boot-th       == 9.12.3      if !os(windows)         Build-Depends: unix >= 2.7 && < 2.9      if arch(wasm32)-        build-depends: ghc-experimental == 9.1202.0+        build-depends: ghc-experimental == 9.1203.0

@@ -53,7 +53,11 @@      build-depends:         base        >= 4.11 && < 4.22,-        ghc-boot-th == 9.12.2+        -- We don't directly depend on any of the modules from `ghc-internal`+        -- But we need to depend on it to work around a hadrian bug.+        -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/25705+        ghc-internal == 9.1203.*,+        ghc-boot-th == 9.12.3      build-depends:       filepath