Unify HasCallStack CPPs in a single place

Author: jasagredo

Control/Concurrent/Async/Internal.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes,
-    ExistentialQuantification #-}
+    ExistentialQuantification, ConstraintKinds, KindSignatures #-}
 #if __GLASGOW_HASKELL__ >= 701
 {-# LANGUAGE Trustworthy #-}
 #endif
@@ -58,7 +58,15 @@ import GHC.IO hiding (finally, onException)
 import GHC.Conc (ThreadId(..), labelThread)
 
 #ifdef DEBUG_AUTO_LABEL
-import GHC.Stack
+import qualified GHC.Stack
+#else
+import qualified GHC.Exts
+#endif
+
+#ifdef DEBUG_AUTO_LABEL
+type DebugCallStack = GHC.Stack.HasCallStack
+#else
+type DebugCallStack = () :: GHC.Exts.Constraint
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -100,53 +108,41 @@ compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2
 --
 -- __Use 'withAsync' style functions wherever you can instead!__
 async ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO (Async a)
 async = inline asyncUsing rawForkIO
 
 -- | Like 'async' but using 'forkOS' internally.
 asyncBound ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO (Async a)
 asyncBound = asyncUsing forkOS
 
 -- | Like 'async' but using 'forkOn' internally.
 asyncOn ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> IO a -> IO (Async a)
 asyncOn = asyncUsing . rawForkOn
 
 -- | Like 'async' but using 'forkIOWithUnmask' internally.  The child
 -- thread is passed a function that can be used to unmask asynchronous
 -- exceptions.
 asyncWithUnmask ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)
 asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask)
 
 -- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.  The
 -- child thread is passed a function that can be used to unmask
 -- asynchronous exceptions.
 asyncOnWithUnmask ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)
 asyncOnWithUnmask cpu actionWith =
   asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)
 
 asyncUsing ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   (IO () -> IO ThreadId) -> IO a -> IO (Async a)
 asyncUsing doFork = \action -> do
    var <- newEmptyTMVarIO
@@ -174,35 +170,27 @@ asyncUsing doFork = \action -> do
 -- linear memory.
 --
 withAsync ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> (Async a -> IO b) -> IO b
 withAsync = inline withAsyncUsing rawForkIO
 
 -- | Like 'withAsync' but uses 'forkOS' internally.
 withAsyncBound ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> (Async a -> IO b) -> IO b
 withAsyncBound = withAsyncUsing forkOS
 
 -- | Like 'withAsync' but uses 'forkOn' internally.
 withAsyncOn ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> IO a -> (Async a -> IO b) -> IO b
 withAsyncOn = withAsyncUsing . rawForkOn
 
 -- | Like 'withAsync' but uses 'forkIOWithUnmask' internally.  The
 -- child thread is passed a function that can be used to unmask
 -- asynchronous exceptions.
 withAsyncWithUnmask ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b
 withAsyncWithUnmask actionWith =
   withAsyncUsing rawForkIO (actionWith unsafeUnmask)
@@ -211,17 +199,13 @@ withAsyncWithUnmask actionWith =
 -- child thread is passed a function that can be used to unmask
 -- asynchronous exceptions
 withAsyncOnWithUnmask ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b
 withAsyncOnWithUnmask cpu actionWith =
   withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)
 
 withAsyncUsing ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   (IO () -> IO ThreadId) -> IO a -> (Async a -> IO b) -> IO b
 -- The bracket version works, but is slow.  We can do better by
 -- hand-coding it:
@@ -607,17 +591,13 @@ isCancel e
 -- >   waitEither a b
 --
 race ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO b -> IO (Either a b)
 
 -- | Like 'race', but the result is ignored.
 --
 race_ ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO b -> IO ()
 
 
@@ -631,9 +611,7 @@ race_ ::
 -- >   withAsync right $ \b ->
 -- >   waitBoth a b
 concurrently ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO b -> IO (a,b)
 
 
@@ -642,18 +620,14 @@ concurrently ::
 -- action and return the @Left@.
 --
 concurrentlyE ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
 
 -- | 'concurrently', but ignore the result values
 --
 -- @since 2.1.1
 concurrently_ ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO b -> IO ()
 
 #define USE_ASYNC_VERSIONS 0
@@ -716,9 +690,7 @@ concurrentlyE left right = concurrently' left right (collect [])
             Right r -> collect (r:xs) m
 
 concurrently' ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO b
   -> (IO (Either SomeException (Either a b)) -> IO r)
   -> IO r
@@ -799,9 +771,7 @@ concurrently_ left right = concurrently' left right (collect 0)
 -- inputs without care may lead to resource exhaustion (of memory,
 -- file descriptors, or other limited resources).
 mapConcurrently ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Traversable t => (a -> IO b) -> t a -> IO (t b)
 mapConcurrently f = runConcurrently . traverse (Concurrently . f)
 
@@ -811,47 +781,37 @@ mapConcurrently f = runConcurrently . traverse (Concurrently . f)
 --
 -- @since 2.1.0
 forConcurrently ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Traversable t => t a -> (a -> IO b) -> IO (t b)
 forConcurrently = flip mapConcurrently
 
 -- | `mapConcurrently_` is `mapConcurrently` with the return value discarded;
 -- a concurrent equivalent of 'mapM_'.
 mapConcurrently_ ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   F.Foldable f => (a -> IO b) -> f a -> IO ()
 mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f)
 
 -- | `forConcurrently_` is `forConcurrently` with the return value discarded;
 -- a concurrent equivalent of 'forM_'.
 forConcurrently_ ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   F.Foldable f => f a -> (a -> IO b) -> IO ()
 forConcurrently_ = flip mapConcurrently_
 
 -- | Perform the action in the given number of threads.
 --
 -- @since 2.1.1
 replicateConcurrently ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> IO a -> IO [a]
 replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently
 
 -- | Same as 'replicateConcurrently', but ignore the results.
 --
 -- @since 2.1.1
 replicateConcurrently_ ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> IO a -> IO ()
 replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void
 
@@ -947,9 +907,7 @@ instance (Semigroup a, Monoid a) => Monoid (ConcurrentlyE e a) where
 -- exception, re-runs the action.  The thread terminates only when the
 -- action runs to completion without raising an exception.
 forkRepeat ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO a -> IO ThreadId
 forkRepeat action =
   mask $ \restore ->
@@ -970,9 +928,7 @@ tryAll = try
 -- exception handler.
 {-# INLINE rawForkIO #-}
 rawForkIO ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO () -> IO ThreadId
 rawForkIO action = IO $ \ s ->
    case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
@@ -981,24 +937,19 @@ rawForkIO action = IO $ \ s ->
 
 {-# INLINE rawForkOn #-}
 rawForkOn ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   Int -> IO () -> IO ThreadId
 rawForkOn (I# cpu) action = IO $ \ s ->
    case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
   where
    (IO action_plus) = debugLabelMe >> action
 
-
 debugLabelMe ::
-#ifdef DEBUG_AUTO_LABEL
-  HasCallStack =>
-#endif
+  DebugCallStack =>
   IO ()
 debugLabelMe =
 #ifdef DEBUG_AUTO_LABEL
-  myThreadId >>= flip labelThread (prettyCallStack callStack)
+  myThreadId >>= flip labelThread (GHC.Stack.prettyCallStack callStack)
 #else
   pure ()
 #endif