-- |
--
-- 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 = 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 = 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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
messageParser
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 Parser StackFrame
stackFrameParser forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
 where
  messageParser :: Parser Text
  messageParser :: Parser Text
messageParser = do
    Text
msg <- String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar Parser ()
eol
    Text
msg forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"CallStack (from HasCallStack):" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
eol)

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

    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 = forall a. a -> Maybe a
Just Int
cl
        , stackFrame_method :: Text
stackFrame_method = Text
func
        , stackFrame_inProject :: Maybe Bool
stackFrame_inProject = forall a. a -> Maybe a
Just Bool
True
        , stackFrame_code :: Maybe (HashMap Int Text)
stackFrame_code = forall a. Maybe a
Nothing
        }

-- brittany-disable-next-binding

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

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

    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 = forall a. a -> Maybe a
Just Int
cl
        , stackFrame_method :: Text
stackFrame_method = Text
func
        , stackFrame_inProject :: Maybe Bool
stackFrame_inProject = forall a. a -> Maybe a
Just Bool
True
        , stackFrame_code :: Maybe (HashMap Int Text)
stackFrame_code = forall a. Maybe a
Nothing
        }

stackFrameFunctionTill :: Parser a -> Parser Text
stackFrameFunctionTill :: forall a. Parser a -> Parser Text
stackFrameFunctionTill Parser a
p = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 <-
    (,,)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'))
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (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.
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"in "
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar Parser a
p
  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 = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Parser MessageWithStackFrames
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) String
"<error>" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

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