Parse.hs

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

import Prelude

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

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

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

parseExceptionWithContext
  :: Exception.ExceptionWithContext Exception.SomeException
  -> Either String MessageWithStackFrames
parseExceptionWithContext =
  parse' backtraceParser . Exception.displayExceptionWithContext

-- | 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 = parse' stringExceptionParser . show

-- brittany-disable-next-binding

errorCallParser :: Parser MessageWithStackFrames
errorCallParser =
  MessageWithStackFrames
    <$> messageParser
    <*> manyTill hasCallStackStackFrameParser eof
 where
  messageParser :: Parser Text
  messageParser = do
    msg <- pack <$> manyTill anyChar eol
    msg <$ (string "CallStack (from HasCallStack):" *> eol)

backtraceParser :: Parser MessageWithStackFrames
backtraceParser =
  MessageWithStackFrames
    <$> messageParser
    <*> manyTill hasCallStackStackFrameParser eof
 where
  messageParser :: Parser Text
  messageParser = do
    msg <- pack <$> manyTill anyChar eol
    msg <$ (string "HasCallStack backtrace:" *> eol)

hasCallStackStackFrameParser :: Parser StackFrame
hasCallStackStackFrameParser = do
  func <- stackFrameFunctionTill $ string ", called at "
  (path, ln, cl) <- stackFrameLocationTill $ eol <|> eof

  pure
    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 =
  MessageWithStackFrames
    <$> messageParser
    <*> manyTill stackFrameParser eof
 where
  messageParser :: Parser Text
  messageParser = do
    manyTill anyChar (try $ string "throwString called with:") *> eol *> eol
    pack <$> manyTill anyChar (try $ eol *> string "Called from:" *> eol)

  stackFrameParser :: Parser StackFrame
  stackFrameParser = do
    func <- stackFrameFunctionTill $ string " ("
    (path, ln, cl) <- stackFrameLocationTill $ char ')' *> eol <|> eof

    pure
      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 p = spaces *> (pack <$> manyTill anyChar p)

stackFrameLocationTill :: Parser a -> Parser (FilePath, Int, Int)
stackFrameLocationTill p = do
  result <-
    (,,)
      <$> manyTill anyChar (char ':')
      <*> (read <$> manyTill digit (char ':'))
      <*> (read <$> manyTill digit (char ' '))

  -- Ignore the "in package:module" part. TODO: we could use this to set
  -- bsfInProject if we had some more knowledge about project packages.
  void $ string "in "
  void $ manyTill anyChar $ char ':'
  void $ manyTill anyChar p
  pure result

parse'
  :: Parser MessageWithStackFrames
  -> String
  -> Either String MessageWithStackFrames
parse' p = first show . parse (p <* eof) "<error>"

eol :: Parser ()
eol = void endOfLine