+  # GitLab's log viewer renders ANSI colors, but stdout here is not a tty,

+  # so the driver must be told to emit them.

+  RUNTEST_ARGS="${RUNTEST_ARGS:-} --force-colors"

+

+section: base

+issues: #27455

+mrs: !16274

+synopsis:

+  Don't drop `ExceptionContext` in `SomeException(toException)`

+description:

+  Previously the implementation of ``Exception(toException)`` given to `SomeException` would inappropriately drop the carried `ExceptionContext`. Now ``toException = id``, faithfully implementing the semantics proposed in :ref:`CLC Proposal #200 <https://github.com/haskell/core-libraries-committee/issues/200>`.

+

+      DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []]

+    , compareSize

+    , traverseWithKey_

+--

+-- See also: 'compareSize'

+-- | \(O(\min(n,c))\). Compare the number of entries in the map to an @Int@.

+--

+-- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is

+-- more efficient when @c@ is smaller than the size of the map.

+compareSize :: Word64Map a -> Int -> Ordering

+compareSize Nil c0 = compare 0 c0

+compareSize _ c0 | c0 <= 0 = GT

+compareSize t c0 = compare 0 (go t (c0 - 1))

+  where

+    go (Bin _ _ _ _) 0 = -1

+    go (Bin _ _ l r) c

+      | c' < 0 = c'

+      | otherwise = go r c'

+      where

+        c' = go l (c - 1)

+    go _ c = c -- Must be Tip (Nil is never a child of Bin)

+

+-- | \(O(n)\). Visit each key\/value pair in ascending key order, discarding

+-- the results.

+traverseWithKey_ :: Applicative t => (Key -> a -> t ()) -> Word64Map a -> t ()

+traverseWithKey_ f = go

+  where

+    go Nil = pure ()

+    go (Tip k v) = f k v

+    go (Bin _ _ l r) = go l *> go r

+{-# INLINE traverseWithKey_ #-}

+

+    , compareSize

+    , traverseWithKey_

+    , compareSize

+    , traverseWithKey_

+    , compareSize

+    , traverseWithKey_

+  , compareSize

+  , traverseWithKey_

+                     -> Maybe (LocatedA (WarningTxt (GhcPass p)))

+                     -> Maybe (LocatedA (WarningTxt (GhcPass p)))

+import GHC.Parser.Annotation (noLocA, noAnn)

+    IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)

+    IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs)

+toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)

+toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)

+toIfaceStringLiteral sLit = IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit)

+                            {% fmap Just $ amsA' (sLL $1 $> $

+                                DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn)

+                                              (snd $ unLoc $2))}

+                            {% fmap Just $ amsA' (sLL $1 $> $

+                                WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)

+                                           $2 (snd $ unLoc $3))}

+                              (WarningTxt (NoSourceText, noAnn) $1 (snd $ unLoc $4)))) }

+                                          (DeprecatedTxt (NoSourceText, noAnn) $ snd $ unLoc $3))) }

+  LocatedA, LocatedN, LocatedAn,

+  SrcSpanAnnA, SrcSpanAnnN,

+{-# LANGUAGE MagicHash #-}

+{-# LANGUAGE UnboxedTuples #-}

+

+import GHC.Data.SmallArray

+import GHC.Exts (State#, build)

+import GHC.ST (ST(..), runST)

+-- There is an implementation cost: each element is given an insertion tag

+-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their

+-- results by this tag (see Note [Cost of deterministic iteration]). So you

+-- should only use `UniqDFM` if you need the deterministic property.

+-- every value with its insertion tag that can later be used to sort the

+--   data UniqDFM ele = UDFM (Word64Map ele) [ele]

+-- | A type of values carrying an insertion tag

+    {-# UNPACK #-} !Int -- ^ insertion tag

+                                   -- values carry an insertion tag.

+    {-# UNPACK #-} !Int            -- Upper bound on the values' insertion

+                                   -- tags. See Note [Overflow on plusUDFM]

+  -- See Note [UDFM invariants]

+{- Note [UDFM invariants]

+~~~~~~~~~~~~~~~~~~~~~~~~~

+In a map (UDFM m ub):

+

+ (a) The insertion tags of the elements of m are distinct.

+ (b) Every tag lies in [0, ub).

+

+Consequently ub >= size m.

+

+The tags determine the order of deterministic iteration (eltsUDFM,

+udfmToList). See Note [Sorting a UDFM].

+-}

+

+-- | Deterministic. See Note [Cost of deterministic iteration].

+-- | Deterministic. See Note [Cost of deterministic iteration].

+-- The main problem that needs to be solved is overlap on insertion

+-- tags between different keys in two maps.

+--

+-- O(n) in the common case, with an O(n log n) fallback.

+--

+-- See Note [Cost of deterministic iteration].

+-- Specialises k and z into M.foldr on the small-map path.

+foldUDFM k z (UDFM m ub)

+  | M.compareSize m 1 /= GT = M.foldr (k . taggedFst) z m

+  | otherwise               = fold_udfm k z m ub

+

+fold_udfm :: (elt -> a -> a) -> a -> M.Word64Map (TaggedVal elt) -> Int -> a

+{-# NOINLINE fold_udfm #-}

+-- Kept out of line so that foldUDFM's consumers don't inline the sort machinery.

+fold_udfm k z m ub

+  | usePigeonholeSort m ub = foldr k z (pigeonholeSort ub (\_ tv -> tv) m)

+  | otherwise              = foldr k z (map taggedFst (sort_it m))

+

+-- | Like 'foldUDFM' but the function also receives a key.

+--

+-- See Note [Cost of deterministic iteration].

+{- Note [Cost of deterministic iteration]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+Deterministic iteration -- foldUDFM, eltsUDFM, udfmToList, and everything

+built on them -- orders elements by insertion tag. The element with the

+smallest tag can sit anywhere in the map, so every tag must be inspected,

+and, given a @UDFM m ub@ on the pigeonhole-sort path, an array with ub slots

+must be filled, before the first element can be emitted (see

+Note [Sorting a UDFM]). So beyond maps of a single element, deterministic

+iteration cannot stream: demanding any of the result processes the whole

+map. #27459 shows that cost hitting a consumer that only needed to know

+whether the result was non-empty.

+

+So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM;

+for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and

+if you don't need the deterministic order at all, use nonDetStrictFoldUDFM.

+-}

+

+-- | Deterministic, in order of insertion.

+--

+-- See Note [Sorting a UDFM] and Note [Cost of deterministic iteration].

+{-# INLINE eltsUDFM #-}  -- so the small case is a good producer

+                         -- This matters for T13719.

+eltsUDFM (UDFM m ub)

+  | M.compareSize m 1 /= GT = build (\c n -> M.foldr (c . taggedFst) n m)

+  | otherwise               = elts_udfm m ub

+

+elts_udfm :: M.Word64Map (TaggedVal elt) -> Int -> [elt]

+{-# NOINLINE elts_udfm #-}

+-- Kept out of line so that eltsUDFM's consumers don't inline the sort machinery.

+elts_udfm m ub

+  | usePigeonholeSort m ub = pigeonholeSort ub (\_ tv -> tv) m

+  | otherwise              = map taggedFst (sort_it m)

+

+{- Note [Sorting a UDFM]

+~~~~~~~~~~~~~~~~~~~~~~~~

+Deterministic iteration must yield a map's elements in order of their

+insertion tags. The obvious way is to sort on the tags, but we can do better:

+in (UDFM m ub) the tags are distinct indices into [0, ub) (see

+Note [UDFM invariants]), so each element can simply be placed at its own

+tag in an ub-slot array, which is then read back in index order. This is

+pigeonhole sort, with one element per hole.

+

+Cost: writing the elements is O(n) for n = M.size m, while allocating the

+array and reading it back are O(ub). Since n <= ub the total is O(ub). No

+comparisons are made.

+

+So the method wins only while the array stays dense, and ub never shrinks

+(overwrites keep bumping it, delete/filter shrink n but not ub).

+usePigeonholeSort therefore takes this path only when ub <= 4 * n, which

+bounds its cost at O(n), and falls back to the O(n log n) comparison sort

+otherwise.

+

+Unfilled slots contain a TaggedVal with tag -1 and value

+@unsafeCoerce () :: r@. This is safe because the value is never used: only

+slots with non-negative tags are read.

+

+pigeonholeSort also avoids intermediate lists: it fills the array by

+traversing the map directly, and emits its readout with 'build', so the foldr

+in fold_udfm fuses with it. This contributes significantly to the allocation

+reductions in InstanceMatching1 in !16292.

+-}

+

+-- | @ub <= 4 * size m@, computed without a full 'M.size' traversal.

+usePigeonholeSort :: M.Word64Map a -> Int -> Bool

+usePigeonholeSort m ub = M.compareSize m ceil_ub_div_4 /= LT

+  where

+    ceil_ub_div_4 = (ub + 3) `div` 4  -- ceil(ub/4): ub <= 4*n iff n >= ceil(ub/4)

+

+-- | Order the map's elements by tag. The tags must be distinct and in

+-- @[0, ub)@, and @mk@ must preserve them. See Note [Sorting a UDFM].

+pigeonholeSort :: forall e r. Int

+              -> (M.Key -> TaggedVal e -> TaggedVal r)

+              -> M.Word64Map (TaggedVal e)

+              -> [r]

+{-# INLINE pigeonholeSort #-}  -- Specialise mk and enable foldr/build fusion.

+pigeonholeSort ub mk m = build gen

+  where

+    -- The tag -1 marks unfilled slots; the value field is never read, but it

+    -- is strict, so it needs a WHNF value of type r. See Note [Sorting a UDFM].

+    hole :: TaggedVal r

+    hole = TaggedVal (unsafeCoerce ()) (-1)

+

+    fill :: SmallMutableArray s (TaggedVal r) -> State# s -> (# State# s, () #)

+    fill marr s = case M.traverseWithKey_ write m of ST st -> st s

+      where

+        write k tv = ST (\s' ->

+          (# writeSmallArray marr (taggedSnd tv) (mk k tv) s', () #))

+

+    gen :: forall b. (r -> b -> b) -> b -> b

+    gen cons nil = runST (ST (\s0 ->

+      case newSmallArray ub hole s0 of

+        (# s1, marr #) -> case fill marr s1 of

+          (# s2, () #) -> case unsafeFreezeSmallArray marr s2 of

+            (# s3, arr #) -> (# s3, readout arr 0 #)))

+      where

+        readout :: SmallArray (TaggedVal r) -> Int -> b

+        readout arr j

+          | j >= ub   = nil

+          | t < 0     = readout arr (j + 1)

+          | otherwise = cons v (readout arr (j + 1))

+          where TaggedVal v t = indexSmallArray arr j

+

+--

+-- O(n) in the common case, with an O(n log n) fallback.

+--

+-- See Note [Cost of deterministic iteration].

+-- NB: no INLINE, unlike eltsUDFM. udfmToList's one hot consumer is

+-- traverseUSDFM in the pattern-match checker, which doesn't fuse. Inlining

+-- the size dispatch into it regresses T17836.

+udfmToList (UDFM m ub)

+  | M.compareSize m 1 /= GT =

+      M.foldrWithKey (\k tv r -> (mkUniqueGrimily k, taggedFst tv) : r) [] m

+  | usePigeonholeSort m ub = pigeonholeSort ub

+      (\k tv -> TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv)) m

+  | otherwise =

+      [ (mkUniqueGrimily k, taggedFst v)

+      | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]

+type instance XDeprecatedTxt       (GhcPass _) = (SourceText, AnnPragma)

+type instance XWarningTxt          (GhcPass _) = (SourceText, AnnPragma)

+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA

+            (NoSourceText, _)   -> pp_ws ws

+            (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"

+          (NoSourceText, _)   -> pp_ws ds

+          (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}"

+  * The implementation of `toException` in `SomeException`'s `Exception` instance no longer drops exception context, in keeping with the behavior originally proposed in [CLC Proposal #200](https://github.com/haskell/core-libraries-committee/issues/200).

+import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++), id)

+    -- | 'toException' converts an exception into the existential 'SomeException'

+    -- wrapper type.

+    --

+    -- In doing so, 'toException' should not /add/ an 'ExceptionContext'.

+    --

+    --   - In most cases, the exception does not store its own 'ExceptionContext'.

+    --     The default implementation of 'toException' (which does not store any

+    --     'ExceptionContext') is suitable for these cases.

+    --   - In the rare case that the exception itself stores an 'ExceptionContext',

+    --     this context should be preserved by 'toException'.

+-- | NB: this instance preserves the attached 'ExceptionContext'.

+    toException = id

+parser.add_argument("--force-colors", action="store_true",

+                        help="emit ANSI colors even when stdout is not a tty (e.g. for CI logs)")

+# config.supports_colors deliberately stays tty-based: it also guards

+# terminal-title updates, which must not end up in a CI log.

+term_color.enable_color = config.supports_colors or args.force_colors

+    summary(t, sys.stdout, color=term_color.enable_color, junit_path=args.junit)

+# Whether to emit color escapes; set in runtests.py.

+# For renderers that serve several sinks: `enabled` says whether *this* sink

+# takes color (the summary is written both to stdout and to a plain-text file).

+def colored_if(enabled: bool, color: Color, s: str) -> str:

+    return colored(color, s) if enabled else s

+from term_color import Color, colored_if

+def _result_directory(opts: TestOptions) -> str:

+    # The test's source directory, relative to the GHC source root, so it reads

+    # the same regardless of which directory `make` was invoked from.

+    srcdir = opts.srcdir

+    if srcdir is None:

+        return ''

+    try:

+        return os.path.relpath(srcdir, config.top.parent)

+    except ValueError:

+        # No relative path exists (e.g. different Windows drives); the

+        # absolute path is still more useful than nothing.

+        return str(srcdir)

+

+    directory = _result_directory(opts)