-- |
--
-- 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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure StackFrame
defaultStackFrame
            { stackFrame_file :: Text
stackFrame_file = String -> Text
pack String
path
            , stackFrame_lineNumber :: Int
stackFrame_lineNumber = Int
ln
            , stackFrame_columnNumber :: Maybe Int
stackFrame_columnNumber = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
cl
            , stackFrame_method :: Text
stackFrame_method = Text
func
            , stackFrame_inProject :: Maybe Bool
stackFrame_inProject = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            , stackFrame_code :: Maybe (HashMap Int Text)
stackFrame_code = Maybe (HashMap Int Text)
forall a. Maybe a
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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure StackFrame
defaultStackFrame
            { stackFrame_file :: Text
stackFrame_file = String -> Text
pack String
path
            , stackFrame_lineNumber :: Int
stackFrame_lineNumber = Int
ln
            , stackFrame_columnNumber :: Maybe Int
stackFrame_columnNumber = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
cl
            , stackFrame_method :: Text
stackFrame_method = Text
func
            , stackFrame_inProject :: Maybe Bool
stackFrame_inProject = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            , stackFrame_code :: Maybe (HashMap Int Text)
stackFrame_code = Maybe (HashMap Int Text)
forall a. Maybe a
Nothing
            }

stackFrameFunctionTill :: Parser a -> Parser Text
stackFrameFunctionTill :: 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 (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 :: 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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (String, Int, Int)
result

parse'
    :: Exception.Exception e
    => Parser MessageWithStackFrames
    -> e
    -> Either String MessageWithStackFrames
parse' :: Parser MessageWithStackFrames
-> e -> Either String MessageWithStackFrames
parse' Parser MessageWithStackFrames
p = (ParseError -> String)
-> Either ParseError MessageWithStackFrames
-> Either String MessageWithStackFrames
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 (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