module Debug.Print.StackTraceDebug where
import Control.Concurrent
import Debug.Trace
import GHC.Stack
import GHC.SrcLoc
import System.Info
import Data.List
import Data.List.Split
import System.Exit
debugMode :: Bool
debugMode = True
debugTraceIO :: (?loc :: CallStack) => String -> IO ()
debugTraceIO message = do
callStacks <- return(getCallStack (?loc))
let callStack = Data.List.last callStacks
let callOrigin = snd callStack
let pathToFileName = srcLocModule callOrigin
let fileName = srcLocFile callOrigin
let lineNumber = show(srcLocStartLine callOrigin)
noMonadThreadId <- myThreadId
let threadName = show noMonadThreadId
let threadNameWords = splitOn " " threadName
let threadNumberString = Data.List.last threadNameWords
let fileNameSplit = if (("win" `isInfixOf` os) || ("Win" `isInfixOf` os) || "mingw" `isInfixOf` os)
then splitOn "\\" fileName
else splitOn "/" fileName
let fileNameNoCruff = if (length fileNameSplit > 1)
then last (tail fileNameSplit)
else head fileNameSplit
let lineOne = message ++ " in" ++ " thread" ++ " " ++ "\"" ++ threadNumberString ++ "\"" ++ " :"
let lineTwo = " " ++ "at " ++ pathToFileName ++ ".call" ++ "(" ++ fileNameNoCruff ++ ":" ++ lineNumber ++ ")"
let toPrint = if ((Data.List.isInfixOf "win" os) || (Data.List.isInfixOf "Win" os) || (Data.List.isInfixOf "mingw" os))
then lineOne ++ "\r\n" ++ lineTwo ++ "\r\n"
else lineOne ++ "\n" ++ lineTwo ++ "\n"
if debugMode
then traceIO toPrint
else return()
fatalAssert :: (?loc :: CallStack) => Bool -> String -> IO ()
fatalAssert assertion message =
if not debugMode
then return()
else if assertion
then return()
else do
callStacks <- return(getCallStack (?loc))
let callStack = Data.List.last callStacks
let callOrigin = snd callStack
let pathToFileName = srcLocModule callOrigin
let fileName = srcLocFile callOrigin
let lineNumber = show(srcLocStartLine callOrigin)
noMonadThreadId <- myThreadId
let threadName = show noMonadThreadId
let threadNameWords = splitOn " " threadName
let threadNumberString = Data.List.last threadNameWords
let fileNameSplit = if (("win" `isInfixOf` os) || ("Win" `isInfixOf` os) || "mingw" `isInfixOf` os)
then splitOn "\\" fileName
else splitOn "/" fileName
let fileNameNoCruff = if (length fileNameSplit > 1)
then last (tail fileNameSplit)
else head fileNameSplit
let lineOne = message ++ " in" ++ " thread" ++ " " ++ "\"" ++ threadNumberString ++ "\"" ++ " :"
let lineTwo = " " ++ "at " ++ pathToFileName ++ ".call" ++ "(" ++ fileNameNoCruff ++ ":" ++ lineNumber ++ ")"
let toPrint = if ((Data.List.isInfixOf "win" os) || (Data.List.isInfixOf "Win" os) || (Data.List.isInfixOf "mingw" os))
then lineOne ++ "\r\n" ++ lineTwo ++ "\r\n"
else lineOne ++ "\n" ++ lineTwo ++ "\n"
traceIO toPrint
die "This application died due to a fatal assertion."
prt :: (?loc :: CallStack) => String -> IO ()
prt = debugTraceIO
test :: IO()
test = do
fatalAssert True "Error message"
debugTraceIO "foobarbaz"
debugTraceIO "lalalalaaaaa"
prt "Shorthand for debugTraceIO"
fatalAssert False "premature death in StackTraceDebug.test"