-- |
--
-- Parse error messages for @'HasCallStack'@ information.
module Network.Bugsnag.Exception.Parse
  ( MessageWithStackFrames (..)
  , parseErrorCall
  , parseStringException
  ) where

import Prelude

import qualified Control.Exception as Exception
  ( ErrorCall
  , Exception
  , SomeException
  )
import Control.Monad (void)
import Data.Bifunctor (first)
import Data.Bugsnag
import Data.Text (Text, pack)
import Text.Parsec
import Text.Parsec.String

data MessageWithStackFrames = MessageWithStackFrames
  { MessageWithStackFrames -> Text
mwsfMessage :: Text
  , MessageWithStackFrames -> [StackFrame]
mwsfStackFrames :: [StackFrame]
  }

-- | Parse an @'ErrorCall'@ for @'HasCallStack'@ information
parseErrorCall :: Exception.ErrorCall -> Either String MessageWithStackFrames
parseErrorCall :: ErrorCall -> Either String MessageWithStackFrames
parseErrorCall = Parser MessageWithStackFrames
-> ErrorCall -> Either String MessageWithStackFrames
forall e.
Exception e =>
Parser MessageWithStackFrames
-> e -> Either String MessageWithStackFrames
parse' Parser MessageWithStackFrames
errorCallParser

-- | Parse a @'StringException'@ for @'HasCallStack'@ information
--
-- We accept this as @'SomeException'@ so that this library doesn't depend on
-- any one concrete library that has @'throwString'@ (there are two right now,
-- sigh.)
parseStringException
  :: Exception.SomeException -> Either String MessageWithStackFrames
parseStringException :: SomeException -> Either String MessageWithStackFrames
parseStringException = Parser MessageWithStackFrames
-> SomeException -> Either String MessageWithStackFrames
forall e.
Exception e =>
Parser MessageWithStackFrames
-> e -> Either String MessageWithStackFrames
parse' Parser MessageWithStackFrames
stringExceptionParser

-- brittany-disable-next-binding

errorCallParser :: Parser MessageWithStackFrames
errorCallParser :: Parser MessageWithStackFrames
errorCallParser =
  Text -> [StackFrame] -> MessageWithStackFrames
MessageWithStackFrames
    (Text -> [StackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity Text
-> ParsecT
     String () Identity ([StackFrame] -> MessageWithStackFrames)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Text
messageParser
    ParsecT String () Identity ([StackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity [StackFrame]
-> Parser MessageWithStackFrames
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity StackFrame
-> ParsecT String () Identity ()
-> ParsecT String () Identity [StackFrame]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity StackFrame
stackFrameParser ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
 where
  messageParser :: Parser Text
  messageParser :: ParsecT String () Identity Text
messageParser = do
    Text
msg <- String -> Text
pack (String -> Text)
-> ParsecT String () Identity String
-> ParsecT String () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String () Identity ()
eol
    Text
msg Text
-> ParsecT String () Identity () -> ParsecT String () Identity Text
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"CallStack (from HasCallStack):" ParsecT String () Identity String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
eol)

  stackFrameParser :: Parser StackFrame
  stackFrameParser :: ParsecT String () Identity StackFrame
stackFrameParser = do
    Text
func <- ParsecT String () Identity String
-> ParsecT String () Identity Text
forall a. Parser a -> ParsecT String () Identity Text
stackFrameFunctionTill (ParsecT String () Identity String
 -> ParsecT String () Identity Text)
-> ParsecT String () Identity String
-> ParsecT String () Identity Text
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
", called at "
    (String
path, Int
ln, Int
cl) <- ParsecT String () Identity () -> Parser (String, Int, Int)
forall a. Parser a -> Parser (String, Int, Int)
stackFrameLocationTill (ParsecT String () Identity () -> Parser (String, Int, Int))
-> ParsecT String () Identity () -> Parser (String, Int, Int)
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity ()
eol ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

    StackFrame -> ParsecT String () Identity StackFrame
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      StackFrame
defaultStackFrame
        { stackFrame_file = pack path
        , stackFrame_lineNumber = ln
        , stackFrame_columnNumber = Just cl
        , stackFrame_method = func
        , stackFrame_inProject = Just True
        , stackFrame_code = Nothing
        }

-- brittany-disable-next-binding

stringExceptionParser :: Parser MessageWithStackFrames
stringExceptionParser :: Parser MessageWithStackFrames
stringExceptionParser =
  Text -> [StackFrame] -> MessageWithStackFrames
MessageWithStackFrames
    (Text -> [StackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity Text
-> ParsecT
     String () Identity ([StackFrame] -> MessageWithStackFrames)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Text
messageParser
    ParsecT String () Identity ([StackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity [StackFrame]
-> Parser MessageWithStackFrames
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity StackFrame
-> ParsecT String () Identity ()
-> ParsecT String () Identity [StackFrame]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity StackFrame
stackFrameParser ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
 where
  messageParser :: Parser Text
  messageParser :: ParsecT String () Identity Text
messageParser = do
    ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"throwString called with:") ParsecT String () Identity String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
eol ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
eol
    String -> Text
pack (String -> Text)
-> ParsecT String () Identity String
-> ParsecT String () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity () -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity ()
eol ParsecT String () Identity ()
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Called from:" ParsecT String () Identity String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
eol)

  stackFrameParser :: Parser StackFrame
  stackFrameParser :: ParsecT String () Identity StackFrame
stackFrameParser = do
    Text
func <- ParsecT String () Identity String
-> ParsecT String () Identity Text
forall a. Parser a -> ParsecT String () Identity Text
stackFrameFunctionTill (ParsecT String () Identity String
 -> ParsecT String () Identity Text)
-> ParsecT String () Identity String
-> ParsecT String () Identity Text
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
" ("
    (String
path, Int
ln, Int
cl) <- ParsecT String () Identity () -> Parser (String, Int, Int)
forall a. Parser a -> Parser (String, Int, Int)
stackFrameLocationTill (ParsecT String () Identity () -> Parser (String, Int, Int))
-> ParsecT String () Identity () -> Parser (String, Int, Int)
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')' ParsecT String () Identity Char
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
eol ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

    StackFrame -> ParsecT String () Identity StackFrame
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      StackFrame
defaultStackFrame
        { stackFrame_file = pack path
        , stackFrame_lineNumber = ln
        , stackFrame_columnNumber = Just cl
        , stackFrame_method = func
        , stackFrame_inProject = Just True
        , stackFrame_code = Nothing
        }

stackFrameFunctionTill :: Parser a -> Parser Text
stackFrameFunctionTill :: forall a. Parser a -> ParsecT String () Identity Text
stackFrameFunctionTill Parser a
p = ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity Text
-> ParsecT String () Identity Text
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Text
pack (String -> Text)
-> ParsecT String () Identity String
-> ParsecT String () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> Parser a -> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar Parser a
p)

stackFrameLocationTill :: Parser a -> Parser (FilePath, Int, Int)
stackFrameLocationTill :: forall a. Parser a -> Parser (String, Int, Int)
stackFrameLocationTill Parser a
p = do
  (String, Int, Int)
result <-
    (,,)
      (String -> Int -> Int -> (String, Int, Int))
-> ParsecT String () Identity String
-> ParsecT String () Identity (Int -> Int -> (String, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')
      ParsecT String () Identity (Int -> Int -> (String, Int, Int))
-> ParsecT String () Identity Int
-> ParsecT String () Identity (Int -> (String, Int, Int))
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'))
      ParsecT String () Identity (Int -> (String, Int, Int))
-> ParsecT String () Identity Int -> Parser (String, Int, Int)
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '))

  -- Ignore the "in package:module" part. TODO: we could use this to set
  -- bsfInProject if we had some more knowledge about project packages.
  ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"in "
  ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity Char
 -> ParsecT String () Identity String)
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
  ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> Parser a -> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar Parser a
p
  (String, Int, Int) -> Parser (String, Int, Int)
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String, Int, Int)
result

parse'
  :: Exception.Exception e
  => Parser MessageWithStackFrames
  -> e
  -> Either String MessageWithStackFrames
parse' :: forall e.
Exception e =>
Parser MessageWithStackFrames
-> e -> Either String MessageWithStackFrames
parse' Parser MessageWithStackFrames
p = (ParseError -> String)
-> Either ParseError MessageWithStackFrames
-> Either String MessageWithStackFrames
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseError -> String
forall a. Show a => a -> String
show (Either ParseError MessageWithStackFrames
 -> Either String MessageWithStackFrames)
-> (e -> Either ParseError MessageWithStackFrames)
-> e
-> Either String MessageWithStackFrames
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser MessageWithStackFrames
-> String -> String -> Either ParseError MessageWithStackFrames
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Parser MessageWithStackFrames
p Parser MessageWithStackFrames
-> ParsecT String () Identity () -> Parser MessageWithStackFrames
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) String
"<error>" (String -> Either ParseError MessageWithStackFrames)
-> (e -> String) -> e -> Either ParseError MessageWithStackFrames
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show

eol :: Parser ()
eol :: ParsecT String () Identity ()
eol = ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
endOfLine