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

import Prelude

import Control.Exception (ErrorCall, Exception, SomeException)
import Control.Monad (void)
import Data.Bifunctor (first)
import Data.Text (Text)
import qualified Data.Text as T
import Network.Bugsnag.StackFrame
import Numeric.Natural
import Text.Parsec
import Text.Parsec.String

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

-- | Parse an @'ErrorCall'@ for @'HasCallStack'@ information
parseErrorCall :: 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 :: 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 -> [BugsnagStackFrame] -> MessageWithStackFrames
MessageWithStackFrames
    (Text -> [BugsnagStackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity Text
-> ParsecT
     String () Identity ([BugsnagStackFrame] -> MessageWithStackFrames)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Text
messageParser
    ParsecT
  String () Identity ([BugsnagStackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity [BugsnagStackFrame]
-> Parser MessageWithStackFrames
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity BugsnagStackFrame
-> ParsecT String () Identity ()
-> ParsecT String () Identity [BugsnagStackFrame]
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 BugsnagStackFrame
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
T.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 BugsnagStackFrame
    stackFrameParser :: ParsecT String () Identity BugsnagStackFrame
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, Natural
ln, Natural
cl) <- ParsecT String () Identity () -> Parser (String, Natural, Natural)
forall a. Parser a -> Parser (String, Natural, Natural)
stackFrameLocationTill (ParsecT String () Identity ()
 -> Parser (String, Natural, Natural))
-> ParsecT String () Identity ()
-> Parser (String, Natural, Natural)
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

        BugsnagStackFrame -> ParsecT String () Identity BugsnagStackFrame
forall (f :: * -> *) a. Applicative f => a -> f a
pure BugsnagStackFrame :: String
-> Natural
-> Maybe Natural
-> Text
-> Maybe Bool
-> Maybe BugsnagCode
-> BugsnagStackFrame
BugsnagStackFrame
            { bsfFile :: String
bsfFile = String
path
            , bsfLineNumber :: Natural
bsfLineNumber = Natural
ln
            , bsfColumnNumber :: Maybe Natural
bsfColumnNumber = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
cl
            , bsfMethod :: Text
bsfMethod = Text
func
            , bsfInProject :: Maybe Bool
bsfInProject = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            , bsfCode :: Maybe BugsnagCode
bsfCode = Maybe BugsnagCode
forall a. Maybe a
Nothing
            }

-- brittany-disable-next-binding

stringExceptionParser :: Parser MessageWithStackFrames
stringExceptionParser :: Parser MessageWithStackFrames
stringExceptionParser = Text -> [BugsnagStackFrame] -> MessageWithStackFrames
MessageWithStackFrames
    (Text -> [BugsnagStackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity Text
-> ParsecT
     String () Identity ([BugsnagStackFrame] -> MessageWithStackFrames)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Text
messageParser
    ParsecT
  String () Identity ([BugsnagStackFrame] -> MessageWithStackFrames)
-> ParsecT String () Identity [BugsnagStackFrame]
-> Parser MessageWithStackFrames
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity BugsnagStackFrame
-> ParsecT String () Identity ()
-> ParsecT String () Identity [BugsnagStackFrame]
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 BugsnagStackFrame
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
T.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 BugsnagStackFrame
    stackFrameParser :: ParsecT String () Identity BugsnagStackFrame
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, Natural
ln, Natural
cl) <- ParsecT String () Identity () -> Parser (String, Natural, Natural)
forall a. Parser a -> Parser (String, Natural, Natural)
stackFrameLocationTill (ParsecT String () Identity ()
 -> Parser (String, Natural, Natural))
-> ParsecT String () Identity ()
-> Parser (String, Natural, Natural)
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

        BugsnagStackFrame -> ParsecT String () Identity BugsnagStackFrame
forall (f :: * -> *) a. Applicative f => a -> f a
pure BugsnagStackFrame :: String
-> Natural
-> Maybe Natural
-> Text
-> Maybe Bool
-> Maybe BugsnagCode
-> BugsnagStackFrame
BugsnagStackFrame
            { bsfFile :: String
bsfFile = String
path
            , bsfLineNumber :: Natural
bsfLineNumber = Natural
ln
            , bsfColumnNumber :: Maybe Natural
bsfColumnNumber = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
cl
            , bsfMethod :: Text
bsfMethod = Text
func
            , bsfInProject :: Maybe Bool
bsfInProject = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            , bsfCode :: Maybe BugsnagCode
bsfCode = Maybe BugsnagCode
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
T.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, Natural, Natural)
stackFrameLocationTill :: Parser a -> Parser (String, Natural, Natural)
stackFrameLocationTill Parser a
p = do
    (String, Natural, Natural)
result <-
        (,,)
        (String -> Natural -> Natural -> (String, Natural, Natural))
-> ParsecT String () Identity String
-> ParsecT
     String
     ()
     Identity
     (Natural -> Natural -> (String, Natural, Natural))
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
  (Natural -> Natural -> (String, Natural, Natural))
-> ParsecT String () Identity Natural
-> ParsecT
     String () Identity (Natural -> (String, Natural, Natural))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Natural
forall a. Read a => String -> a
read (String -> Natural)
-> ParsecT String () Identity String
-> ParsecT String () Identity Natural
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 (Natural -> (String, Natural, Natural))
-> ParsecT String () Identity Natural
-> Parser (String, Natural, Natural)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Natural
forall a. Read a => String -> a
read (String -> Natural)
-> ParsecT String () Identity String
-> ParsecT String () Identity Natural
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, Natural, Natural) -> Parser (String, Natural, Natural)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String, Natural, Natural)
result

parse'
    :: 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