Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-ty at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
    ... ... @@ -133,20 +133,32 @@ import GHC.Internal.Stack.Annotation
    133 133 
     -- Annotations
    134 134 
     -- ----------------------------------------------------------------------------
    135 135
    136 
    +
    137 
    +-- | A 'String' only annotation with an optional source location.
    136 138 
     data StringAnnotation where
    137 
    -  StringAnnotation :: String -> StringAnnotation
    139 
    +  StringAnnotation :: !(Maybe SrcLoc) -> String -> StringAnnotation
    138 140
    139 141 
     instance StackAnnotation StringAnnotation where
    140 
    -  displayStackAnnotation (StringAnnotation str) = str
    142 
    +  displayStackAnnotationShort (StringAnnotation _srcLoc str) =
    143 
    +    str
    144 
    +
    145 
    +  sourceLocationOfStackAnnotation (StringAnnotation srcLoc _str) =
    146 
    +    srcLoc
    141 147
    142 148 
     -- | Use the 'Show' instance of a type to display as the 'StackAnnotation'.
    143 149 
     data ShowAnnotation where
    144 
    -  ShowAnnotation :: forall a . Show a => a -> ShowAnnotation
    150 
    +  ShowAnnotation :: forall a . Show a => !(Maybe SrcLoc) -> a -> ShowAnnotation
    145 151
    146 152 
     instance StackAnnotation ShowAnnotation where
    147 
    -  displayStackAnnotation (ShowAnnotation showAnno) = show showAnno
    153 
    +  displayStackAnnotationShort (ShowAnnotation _srcLoc showAnno) =
    154 
    +    show showAnno
    155 
    +
    156 
    +  sourceLocationOfStackAnnotation (ShowAnnotation srcLoc _showAnno) =
    157 
    +    srcLoc
    148 158
    149 159 
     -- | A 'CallStack' stack annotation.
    160 
    +--
    161 
    +-- Captures the whole 'CallStack'.
    150 162 
     newtype CallStackAnnotation = CallStackAnnotation CallStack
    151 163
    152 164 
     instance Show CallStackAnnotation where
    ... ... @@ -154,9 +166,23 @@ instance Show CallStackAnnotation where
    154 166
    155 167 
     -- | Displays the first entry of the 'CallStack'
    156 168 
     instance StackAnnotation CallStackAnnotation where
    157 
    -  displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of
    169 
    +  sourceLocationOfStackAnnotation (CallStackAnnotation cs) =
    170 
    +    callStackHeadSrcLoc cs
    171 
    +
    172 
    +  displayStackAnnotationShort (CallStackAnnotation cs) =
    173 
    +    callStackHeadFunctionName cs
    174 
    +
    175 
    +callStackHeadSrcLoc :: CallStack -> Maybe SrcLoc
    176 
    +callStackHeadSrcLoc cs =
    177 
    +  case getCallStack cs of
    178 
    +    [] -> Nothing
    179 
    +    (_, srcLoc):_ -> Just srcLoc
    180 
    +
    181 
    +callStackHeadFunctionName :: CallStack -> String
    182 
    +callStackHeadFunctionName cs =
    183 
    +  case getCallStack cs of
    158 184 
         [] -> "<unknown source location>"
    159 
    -    ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc
    185 
    +    (fnName, _):_ -> fnName
    160 186
    161 187 
     -- ----------------------------------------------------------------------------
    162 188 
     -- Annotate the CallStack with custom data
    ... ... @@ -172,7 +198,7 @@ instance StackAnnotation CallStackAnnotation where
    172 198 
     --
    173 199 
     -- WARNING: forces the evaluation of @b@ to WHNF.
    174 200 
     {-# NOINLINE annotateStack #-}
    175 
    -annotateStack :: forall a b. (Typeable a, StackAnnotation a) => a -> b -> b
    201 
    +annotateStack :: forall a b. (HasCallStack, Typeable a, StackAnnotation a) => a -> b -> b
    176 202 
     annotateStack ann b = unsafePerformIO $
    177 203 
       annotateStackIO ann (evaluate b)
    178 204
    ... ... @@ -196,9 +222,9 @@ annotateCallStack b = unsafePerformIO $ withFrozenCallStack $
    196 222 
     -- information to stack traces.
    197 223 
     --
    198 224 
     -- WARNING: forces the evaluation of @b@ to WHNF.
    199 
    -annotateStackString :: forall b . String -> b -> b
    225 
    +annotateStackString :: forall b . HasCallStack => String -> b -> b
    200 226 
     annotateStackString ann =
    201 
    -  annotateStack (StringAnnotation ann)
    227 
    +  annotateStack (StringAnnotation (callStackHeadSrcLoc ?callStack) ann)
    202 228
    203 229 
     -- | @'annotateStackShow' showable b@ annotates the evaluation stack of @b@
    204 230 
     -- with the value @showable@.
    ... ... @@ -207,16 +233,16 @@ annotateStackString ann =
    207 233 
     -- information to stack traces.
    208 234 
     --
    209 235 
     -- WARNING: forces the evaluation of @b@ to WHNF.
    210 
    -annotateStackShow :: forall a b . (Typeable a, Show a) => a -> b -> b
    236 
    +annotateStackShow :: forall a b . (HasCallStack, Typeable a, Show a) => a -> b -> b
    211 237 
     annotateStackShow ann =
    212 
    -  annotateStack (ShowAnnotation ann)
    238 
    +  annotateStack (ShowAnnotation (callStackHeadSrcLoc ?callStack) ann)
    213 239
    214 240 
     -- | @'annotateStackIO' showable b@ annotates the evaluation stack of @b@
    215 241 
     -- with the value @showable@.
    216 242 
     --
    217 243 
     -- When decoding the call stack, the annotation frames can be used to add more
    218 244 
     -- information to stack traces.
    219 
    -annotateStackIO :: forall a b . (Typeable a, StackAnnotation a) => a -> IO b -> IO b
    245 
    +annotateStackIO :: forall a b . (HasCallStack, Typeable a, StackAnnotation a) => a -> IO b -> IO b
    220 246 
     annotateStackIO ann (IO act) =
    221 247 
       IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s
    222 248 
     {-# NOINLINE annotateStackIO #-}
    ... ... @@ -226,18 +252,18 @@ annotateStackIO ann (IO act) =
    226 252 
     --
    227 253 
     -- When decoding the call stack, the annotation frames can be used to add more
    228 254 
     -- information to stack traces.
    229 
    -annotateStackStringIO :: forall b . String -> IO b -> IO b
    255 
    +annotateStackStringIO :: forall b . HasCallStack => String -> IO b -> IO b
    230 256 
     annotateStackStringIO ann =
    231 
    -  annotateStackIO (StringAnnotation ann)
    257 
    +  annotateStackIO (StringAnnotation (callStackHeadSrcLoc ?callStack) ann)
    232 258
    233 259 
     -- | @'annotateStackShowIO' msg b@ annotates the evaluation stack of @b@
    234 260 
     -- with the value @msg@.
    235 261 
     --
    236 262 
     -- When decoding the call stack, the annotation frames can be used to add more
    237 263 
     -- information to stack traces.
    238 
    -annotateStackShowIO :: forall a b . (Show a) => a -> IO b -> IO b
    264 
    +annotateStackShowIO :: forall a b . (HasCallStack, Show a) => a -> IO b -> IO b
    239 265 
     annotateStackShowIO ann =
    240 
    -  annotateStackIO (ShowAnnotation ann)
    266 
    +  annotateStackIO (ShowAnnotation (callStackHeadSrcLoc ?callStack) ann)
    241 267
    242 268 
     -- | @'annotateCallStackIO' b@ annotates the evaluation stack of @b@ with the
    243 269 
     -- current 'callstack'.

  • libraries/ghc-experimental/tests/backtraces/T26806a.stderr
    ... ... @@ -3,8 +3,8 @@ T26806a: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
    3 3 
     Backtrace Test
    4 4
    5 5 
     IPE backtrace:
    6 
    -  Lovely annotation
    7 
    -  [1,2,3,4]
    6 
    +  Lovely annotation, called at T26806a.hs:12:7 in main:Main
    7 
    +  [1,2,3,4], called at T26806a.hs:11:5 in main:Main
    8 8 
       annotateCallStackIO, called at T26806a.hs:10:3 in main:Main
    9 9 
     HasCallStack backtrace:
    10 10 
       throwIO, called at T26806a.hs:13:9 in main:Main

  • libraries/ghc-experimental/tests/backtraces/T26806b.stderr
    ... ... @@ -3,8 +3,8 @@ T26806b: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:
    3 3 
     Backtrace Test: 125000000
    4 4
    5 5 
     IPE backtrace:
    6 
    -  Lovely annotation
    7 
    -  [1,2,3,4]
    6 
    +  Lovely annotation, called at T26806b.hs:16:7 in main:Main
    7 
    +  [1,2,3,4], called at T26806b.hs:15:5 in main:Main
    8 8 
       annotateCallStack, called at T26806b.hs:14:3 in main:Main
    9 9 
     HasCallStack backtrace:
    10 10 
       collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception

  • libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
    ... ... @@ -4,6 +4,7 @@ module GHC.Internal.Stack.Annotation where
    4 4
    5 5 
     import GHC.Internal.Base
    6 6 
     import GHC.Internal.Data.Typeable
    7 
    +import GHC.Internal.Stack (SrcLoc, prettySrcLoc)
    7 8
    8 9 
     -- ----------------------------------------------------------------------------
    9 10 
     -- StackAnnotation
    ... ... @@ -13,8 +14,36 @@ import GHC.Internal.Data.Typeable
    13 14 
     -- as the payload of 'AnnFrame' stack frames.
    14 15 
     --
    15 16 
     class StackAnnotation a where
    17 
    +  -- | Display a human readable string for the 'StackAnnotation'.
    18 
    +  --
    19 
    +  -- This is supposed to be the long version of 'displayStackAnnotationShort'
    20 
    +  -- and may contain a source location.
    21 
    +  --
    22 
    +  -- If not provided, 'displayStackAnnotation' is derived from 'sourceLocationOfStackAnnotation'
    23 
    +  -- and 'displayStackAnnotationShort'.
    16 24 
       displayStackAnnotation :: a -> String
    17 25
    26 
    +  -- | Get the 'SrcLoc' of the given 'StackAnnotation'.
    27 
    +  --
    28 
    +  -- This is optional, 'SrcLoc' are not strictly required for 'StackAnnotation', but
    29 
    +  -- it is still heavily encouarged to provide a 'SrcLoc' for better IPE backtraces.
    30 
    +  sourceLocationOfStackAnnotation :: a -> Maybe SrcLoc
    31 
    +
    32 
    +  -- | The description of the StackAnnotation without any metadata such as source locations.
    33 
    +  --
    34 
    +  -- Pefer implementing 'displayStackAnnotationShort' over 'displayStackAnnotation'.
    35 
    +  displayStackAnnotationShort :: a -> String
    36 
    +
    37 
    +  {-# MINIMAL displayStackAnnotation | displayStackAnnotationShort #-}
    38 
    +
    39 
    +  displayStackAnnotation ann =
    40 
    +    displayStackAnnotationShort ann
    41 
    +      ++ case sourceLocationOfStackAnnotation ann of
    42 
    +          Nothing -> ""
    43 
    +          Just srcLoc -> ", called at " ++ prettySrcLoc srcLoc
    44 
    +  sourceLocationOfStackAnnotation _ann = Nothing
    45 
    +  displayStackAnnotationShort = displayStackAnnotation
    46 
    +
    18 47 
     -- ----------------------------------------------------------------------------
    19 48 
     -- Annotations
    20 49 
     -- ----------------------------------------------------------------------------
    ... ... @@ -29,3 +58,5 @@ data SomeStackAnnotation where
    29 58
    30 59 
     instance StackAnnotation SomeStackAnnotation where
    31 60 
       displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
    61 
    +  sourceLocationOfStackAnnotation (SomeStackAnnotation a) = sourceLocationOfStackAnnotation a
    62 
    +  displayStackAnnotationShort (SomeStackAnnotation a) = displayStackAnnotationShort a

  • libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
    1 1 
     Stack annotations:
    2 
    -- (2,3)
    2 
    +- (2,3), called at ann_frame001.hs:5:13 in main:Main
    3 3 
     47
    4 4 
     Stack annotations:
    5 
    -- "bar"
    6 
    -- "foo"
    7 
    -- "tailCallEx"
    5 
    +- "bar", called at ann_frame001.hs:23:9 in main:Main
    6 
    +- "foo", called at ann_frame001.hs:21:11 in main:Main
    7 
    +- "tailCallEx", called at ann_frame001.hs:17:18 in main:Main
    8 8 
     Stack annotations:
    9 
    -- "bar"
    10 
    -- "foo"
    11 
    -- "tailCallEx"
    9 
    +- "bar", called at ann_frame001.hs:23:9 in main:Main
    10 
    +- "foo", called at ann_frame001.hs:21:11 in main:Main
    11 
    +- "tailCallEx", called at ann_frame001.hs:17:18 in main:Main
    12 12 
     40

  • libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
    ... ... @@ -7,5 +7,5 @@ Finish some work
    7 7 
     Some more work in bar
    8 8 
     17711
    9 9 
     Stack annotations:
    10 
    -- bar
    10 
    +- bar, called at ann_frame002.hs:23:29 in main:Main
    11 11 
     - annotateCallStackIO, called at ann_frame002.hs:23:7 in main:Main

  • libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
    1 1 
     47
    2 2 
     Stack annotations:
    3 
    -- "bar"
    4 
    -- "foo"
    5 
    -- "tailCallEx"
    3 
    +- "bar", called at ann_frame003.hs:25:9 in main:Main
    4 
    +- "foo", called at ann_frame003.hs:21:11 in main:Main
    5 
    +- "tailCallEx", called at ann_frame003.hs:16:18 in main:Main
    6 6 
     40

  • libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
    ... ... @@ -13,5 +13,5 @@ Stack annotations:
    13 13 
     - annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
    14 14 
     - annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
    15 15 
     - annotateCallStack, called at ann_frame004.hs:13:10 in main:Main
    16 
    -- bar
    16 
    +- bar, called at ann_frame004.hs:12:29 in main:Main
    17 17 
     - annotateCallStackIO, called at ann_frame004.hs:12:7 in main:Main

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help