module Debug.Record(
Function(..),
Call,
funInfo, fun, var,
debugClear,
debugPrint, debugJSON,
debugView, debugSave
) where
import Debug.Variables
import Control.Exception
import Control.Monad
import Data.IORef
import Data.List.Extra
import System.IO
import System.Directory
import System.Process.Extra
import System.IO.Unsafe
import Text.Show.Functions()
import qualified Data.Map as Map
import qualified Language.Javascript.JQuery as JQuery
import Paths_debug
data Function = Function
{funName :: String
,funSource :: String
,funArguments :: [String]
,funResult :: String
}
deriving (Eq,Ord,Show)
data Call = Call Function (IORef [(String, Var)])
refVariables :: IORef Variables
refVariables = unsafePerformIO $ newIORef newVariables
refCalls :: IORef [Call]
refCalls = unsafePerformIO $ newIORef []
debugClear :: IO ()
debugClear = do
writeIORef refVariables newVariables
writeIORef refCalls []
debugPrint :: IO ()
debugPrint = do
funs <- readIORef refCalls
forM_ (reverse funs) $ \(Call name vars) -> do
putStrLn $ funName name
vars <- readIORef vars
forM_ (reverse vars) $ \(name, v) ->
putStrLn $ " " ++ name ++ " = " ++ show v
debugJSON :: IO String
debugJSON = do
vars <- readIORef refVariables
vars <- return $ map (jsonString . varShow) $ listVariables vars
calls <- readIORef refCalls
let infos = nubOrd [x | Call x _ <- calls]
let infoId = Map.fromList $ zip infos [0::Int ..]
let funs = [jsonMap
[("name",show funName)
,("source",show funSource)
,("arguments",show funArguments)
,("result",show funResult)
]
| Function{..} <- infos]
calls <- forM (reverse calls) $ \(Call info vars) -> do
vars <- readIORef vars
return $ jsonMap $ ("", show $ infoId Map.! info) : [(k, show $ varId v) | (k, v) <- reverse vars]
return $
"{\"functions\":\n" ++ jsonList funs ++
",\"variables\":\n" ++ jsonList vars ++
",\"calls\":\n" ++ jsonList (nubOrd calls) ++
"}"
where
jsonList [] = " []"
jsonList (x:xs) = unlines $ (" [" ++ x) : map (" ," ++) xs ++ [" ]"]
jsonMap xs = "{" ++ intercalate "," [jsonString k ++ ":" ++ v | (k,v) <- xs] ++ "}"
jsonString = show
debugSave :: FilePath -> IO ()
debugSave file = do
html <- readFile =<< getDataFileName "html/debug.html"
debug <- readFile =<< getDataFileName "html/debug.js"
jquery <- readFile =<< JQuery.file
trace <- debugJSON
let script a = "<script>\n" ++ a ++ "\n</script>"
let f x | "trace.js" `isInfixOf` x = script ("var trace =\n" ++ trace ++ ";")
| "debug.js" `isInfixOf` x = script debug
| "code.jquery.com/jquery" `isInfixOf` x = script jquery
| otherwise = x
writeFile file $ unlines $ map f $ lines html
debugView :: IO ()
debugView = do
tdir <- getTemporaryDirectory
file <- bracket
(openTempFile tdir "debug.html")
(hClose . snd)
(return . fst)
debugSave file
system_ file
#if __GLASGOW_HASKELL__ >= 800
instance Show a where
show _ = "?"
#endif
fun :: Show a => String -> (Call -> a) -> a
fun name = funInfo $ Function name [] [] []
funInfo :: Show a => Function -> (Call -> a) -> a
funInfo info f = unsafePerformIO $ do
ref <- newIORef []
let x = Call info ref
atomicModifyIORef refCalls $ \v -> (x:v, ())
return $ f x
var :: Show a => Call -> String -> a -> a
var (Call _ ref) name val = unsafePerformIO $ do
var <- atomicModifyIORef refVariables $ addVariable val
atomicModifyIORef ref $ \v -> ((name, var):v, ())
return val