Cabal/src/Distribution/Compat/Stack.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ImplicitParams #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 module Distribution.Compat.Stack
   6   ( WithCallStack
   7   , CallStack
   8   , annotateCallStackIO
   9   , withFrozenCallStack
  10   , withLexicalCallStack
  11   , callStack
  12   , prettyCallStack
  13   , parentSrcLocPrefix
  14   ) where
  15
  16 import System.IO.Error
  17
  18 #ifdef MIN_VERSION_base
  19 #if MIN_VERSION_base(4,8,1)
  20 #define GHC_STACK_SUPPORTED 1
  21 #endif
  22 #endif
  23
  24 #ifdef GHC_STACK_SUPPORTED
  25 import GHC.Stack
  26 #endif
  27
  28 #ifdef GHC_STACK_SUPPORTED
  29
  30 #if MIN_VERSION_base(4,9,0)
  31 type WithCallStack a = HasCallStack => a
  32 #elif MIN_VERSION_base(4,8,1)
  33 type WithCallStack a = (?callStack :: CallStack) => a
  34 #endif
  35
  36 #if !MIN_VERSION_base(4,9,0)
  37 -- NB: Can't say WithCallStack (WithCallStack a -> a);
  38 -- Haskell doesn't support this kind of implicit parameter!
  39 -- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html
  40 -- Since this function doesn't do anything, it's OK to
  41 -- give it a less good type.
  42 withFrozenCallStack :: WithCallStack (a -> a)
  43 withFrozenCallStack x = x
  44
  45 callStack :: (?callStack :: CallStack) => CallStack
  46 callStack = ?callStack
  47
  48 prettyCallStack :: CallStack -> String
  49 prettyCallStack = showCallStack
  50 #endif
  51
  52 -- | Give the *parent* of the person who invoked this;
  53 -- so it's most suitable for being called from a utility function.
  54 -- You probably want to call this using 'withFrozenCallStack'; otherwise
  55 -- it's not very useful.  We didn't implement this for base-4.8.1
  56 -- because we cannot rely on freezing to have taken place.
  57 --
  58 parentSrcLocPrefix :: WithCallStack String
  59 #if MIN_VERSION_base(4,9,0)
  60 parentSrcLocPrefix =
  61   case getCallStack callStack of
  62     (_:(_, loc):_) -> showLoc loc
  63     [(_, loc)] -> showLoc loc
  64     [] -> error "parentSrcLocPrefix: empty call stack"
  65  where
  66   showLoc loc =
  67     srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "
  68 #else
  69 parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
  70 #endif
  71
  72 -- Yeah, this uses skivvy implementation details.
  73 withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
  74 withLexicalCallStack f =
  75     let stk = ?callStack
  76     in \x -> let ?callStack = stk in f x
  77
  78 #else
  79
  80 data CallStack = CallStack
  81     deriving (Eq, Show)
  82
  83 type WithCallStack a = a
  84
  85 withFrozenCallStack :: a -> a
  86 withFrozenCallStack x = x
  87
  88 callStack :: CallStack
  89 callStack = CallStack
  90
  91 prettyCallStack :: CallStack -> String
  92 prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"
  93
  94 parentSrcLocPrefix :: String
  95 parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
  96
  97 withLexicalCallStack :: (a -> IO b) -> a -> IO b
  98 withLexicalCallStack f = f
  99
 100 #endif
 101
 102 -- | This function is for when you *really* want to add a call
 103 -- stack to raised IO, but you don't have a
 104 -- 'Distribution.Verbosity.Verbosity' so you can't use
 105 -- 'Distribution.Simple.Utils.annotateIO'.  If you have a 'Verbosity',
 106 -- please use that function instead.
 107 annotateCallStackIO :: WithCallStack (IO a -> IO a)
 108 annotateCallStackIO = modifyIOError f
 109   where
 110     f ioe =
 111       ioeSetErrorString ioe
 112         . wrapCallStack
 113         $ ioeGetErrorString ioe
 114     wrapCallStack s =
 115       prettyCallStack callStack ++ "\n" ++ s