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 Data.Maybe
import Data.Tuple.Extra
import System.IO
import System.Directory
import System.IO.Unsafe
import Text.Show.Functions()
import qualified Data.Map as Map
import qualified Language.Javascript.JQuery as JQuery
import Web.Browser
import Paths_debug
import Text.PrettyPrint.ANSI.Leijen as PP
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
calls <- readIORef refCalls
concs <- mapM getCall calls
let docs = map call $ nubOrd $ reverse concs
putDoc (vcat docs <> hardline)
where
getCall :: Call -> IO (Function, [(String, Var)])
getCall (Call f is) = do sv <- readIORef is
return (f, sv)
call :: (Function, [(String, Var)]) -> Doc
call (f, vs) =
let ass = creaAssoc . reverse $ vs
hdr = bold $ header ass f
in hang 5 $ hdr <$$> body ass
creaAssoc :: [(String, Var)] -> [(String, String)]
creaAssoc svs = map (second varShow) svs
header :: [(String, String)] -> Function -> Doc
header ass f = text "\n*" <+>
text (funName f) <+>
arguments ass <+>
text "=" <+>
result ass
arguments :: [(String, String)] -> Doc
arguments ass =
let fass = filter (\(t, _) -> take 4 t == "$arg") ass
args = map snd fass
in hsep (map text args)
result :: [(String, String)] -> Doc
result = text . fromMaybe "no result!" . lookup "$result"
body :: [(String, String)] -> Doc
body svs = vsep $ map bodyLine svs
bodyLine :: (String, String) -> Doc
bodyLine (t, v) = text t <+> text "=" <+> text 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
b <- openBrowser file
unless b $
putStrLn $
"Failed to start a web browser, open: " ++ file ++ "\n" ++
"In future you may wish to use 'debugSave'."
#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