1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-}
-- | A compatibility layer for `CallStack`, so that we can have
-- uniform signatures even in old GHC versions (even if the
-- functionality itself does not work there).
module Data.GI.Base.CallStack
( HasCallStack
, CallStack
, prettyCallStack
, callStack
) where
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack, prettyCallStack, callStack, CallStack)
#elif MIN_VERSION_base(4,8,1)
import Data.List (intercalate)
import qualified GHC.Stack as S
import GHC.SrcLoc (SrcLoc(..))
import GHC.Exts (Constraint)
type HasCallStack = ((?callStack :: S.CallStack) :: Constraint)
type CallStack = [(String, SrcLoc)]
#else
import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
type CallStack = ()
#endif
#if !MIN_VERSION_base(4,9,0)
-- | Return the current `CallStack`.
callStack :: HasCallStack => CallStack
#if MIN_VERSION_base(4,8,1)
callStack = drop 1 (S.getCallStack ?callStack)
#else
callStack = ()
#endif
#endif
#if !MIN_VERSION_base(4,9,0)
prettyCallStack :: CallStack -> String
#if MIN_VERSION_base(4,8,1)
-- | Give a text representation of the current `CallStack`.
prettyCallStack = intercalate "\n" . prettyCallStackLines
where prettySrcLoc :: SrcLoc -> String
prettySrcLoc l = foldr (++) "" [ srcLocFile l, ":"
, show (srcLocStartLine l), ":"
, show (srcLocStartCol l), " in "
, srcLocPackage l, ":", srcLocModule l
]
prettyCallStackLines :: CallStack -> [String]
prettyCallStackLines cs = case cs of
[] -> []
stk -> "CallStack (from HasCallStack):"
: map ((" " ++) . prettyCallSite) stk
prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc
#else
prettyCallStack _ = "<CallStack only available with GHC >= 7.10.2>"
#endif
#endif
|
