{-# LANGUAGE ImplicitParams #-}
module StackTraceDebug where

{- Requires GHC version 7.10.1 (or greater) to compile -}
{- Suggested for use with IntelliJ or EclipseFP -}

import Control.Concurrent -- for myThreadID
import Debug.Trace -- for trace
import GHC.Stack -- for errorWithStackTrace :: String -> a, currentCallStack :: IO [String]
import GHC.SrcLoc -- this is for getting the fine name, line number, etc.
import System.Info
import Data.List -- isInfixOf, intercalate
import Data.List.Split -- for split function

--
-- | Set to "False" to disable print statements with stack traces.
--
debugMode :: Bool
debugMode = True

--
-- | Prints message with a one line stack trace (formatted like a Java Exception for IDE usability)
--
debugTraceIO :: (?loc :: CallStack) => String -> IO ()
debugTraceIO message = do
  callStacks <- return(getCallStack (?loc)) -- returns [(String, SrcLoc)]
  let callStack = Data.List.last(callStacks) -- returns (String, SrcLoc)
  let callOrigin =  snd callStack -- returns SrcLoc
  let pathToFileName =  srcLocModule callOrigin
  let fileName =  srcLocFile callOrigin
  let lineNumber =  show(srcLocStartLine callOrigin)
  noMonadThreadId <- myThreadId -- myThreadId returns IO(ThreadID)
  let threadName =  show(noMonadThreadId)
  let threadNameWords =  Data.List.Split.splitOn " " threadName -- break up thread name along spaces
  let threadNumberString =  Data.List.last threadNameWords -- this isn't working
  let fileNameSplit = if ((Data.List.isInfixOf "win" os) || (Data.List.isInfixOf "Win" os) || (Data.List.isInfixOf "mingw" os))-- Data.List.Split.splitOn " " threadName)
                        then Data.List.Split.splitOn windowsSeparator fileName
                        else Data.List.Split.splitOn linuxSeparator fileName
  let fileNameSplitDropHead = if (length fileNameSplit > 1)
                                then tail fileNameSplit
                                else fileNameSplit
  let fileNameParsed = if ((Data.List.isInfixOf "win" os) || (Data.List.isInfixOf "Win" os) || (Data.List.isInfixOf "mingw" os))-- Data.List.Split.splitOn " " threadName)
                         then intercalate windowsSeparator fileNameSplitDropHead
                         else intercalate linuxSeparator fileNameSplitDropHead
  let lineOne =  message ++ " in" ++ " thread" ++ " " ++ "\"" ++ threadNumberString ++ "\"" ++ " :"
  let lineTwo =  "    "  ++ "at " ++ pathToFileName ++ ".call" ++ "(" ++ fileNameParsed ++ ":" ++ lineNumber ++ ")"
  let toPrint = if ((Data.List.isInfixOf "win" os) || (Data.List.isInfixOf "Win" os) || (Data.List.isInfixOf "mingw" os))
                  then  lineOne ++ windowsNewline ++ lineTwo ++ windowsNewline
                  else  lineOne ++ linuxNewLine ++ lineTwo ++ linuxNewLine -- linesOneAndTwo = unlines [lineOne, lineTwo])
  if debugMode
     then Debug.Trace.traceIO toPrint
     else return()

windowsNewline :: [Char]
windowsNewline = "\r\n"

linuxNewLine :: [Char]
linuxNewLine = "\n"

windowsSeparator :: [Char]
windowsSeparator = "\\"

linuxSeparator :: [Char]
linuxSeparator = "/"

main :: IO()
main = do
  debugTraceIO "foobarbaz"
  debugTraceIO "lalalalaaaaa"
  
{-

Sample output:

foobarbaz in thread "1" :
    at StackTraceDebug.call(StackTraceDebug.hs:68)

lalalalaaaaa in thread "1" :
    at StackTraceDebug.call(StackTraceDebug.hs:69)  
-}
