module Debug.Hoed.Stk
(
observe
, runO
, printO
, observeTempl
, observedTypes
, observeCC
, observe'
, Identifier(..)
,(*>>=),(>>==),(>>=*)
, logO
, Observer(..)
, Observable(..)
, (<<)
, thunk
, nothunk
, send
, observeBase
, observeOpaque
, debugO
, CDS(..)
, Generic
) where
import Debug.Hoed.Stk.Observe
import Debug.Hoed.Stk.Render
import Debug.Hoed.Stk.DemoGUI
import Prelude hiding (Right)
import qualified Prelude
import System.IO
import Data.Maybe
import Control.Monad
import Data.Array as Array
import Data.List
import Data.Char
import System.Environment
import Language.Haskell.TH
import GHC.Generics
import Data.IORef
import System.IO.Unsafe
import Data.Graph.Libgraph
import Graphics.UI.Threepenny(startGUI,defaultConfig,Config(..))
import System.Directory(createDirectoryIfMissing)
debugO :: IO a -> IO [Event]
debugO program =
do { initUniq
; startEventStream
; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"
; ourCatchAllIO (do { program ; return () })
(hPutStrLn stderr . errorMsg)
; events <- endEventStream
; return events
}
printO :: (Show a) => a -> IO ()
printO expr = runO (print expr)
putStrO :: String -> IO ()
putStrO expr = runO (putStr expr)
runO :: IO a -> IO ()
runO program = do
let slices = []
compGraph <- runO' program
debugSession slices compGraph
return ()
runO' :: IO a -> IO CompGraph
runO' program = do
args <- getArgs
setPushMode (parseArgs args)
hPutStrLn stderr "=== program output ===\n"
events <- debugO program
let cdss = eventsToCDS events
let cdss1 = rmEntrySet cdss
let cdss2 = simplifyCDSSet cdss1
let eqs = ((sortBy byStack) . renderCompStmts) cdss2
let ct = mkGraph eqs
hPutStrLn stderr "\n=== Statistics ===\n"
let e = length events
n = length eqs
d = treeDepth ct
b = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) (length . leafs $ ct))
hPutStrLn stderr $ "e = " ++ show e
hPutStrLn stderr $ "n = " ++ show n
hPutStrLn stderr $ "arc = " ++ show (length . arcs $ ct)
hPutStrLn stderr $ "d = " ++ show d
hPutStrLn stderr $ "b = " ++ show b
hPutStrLn stderr "\n=== Debug session === \n"
hPutStrLn stderr (showWithStack eqs)
return ct
leafs g = filter (\v -> succs g v == []) (vertices g)
logO :: FilePath -> IO a -> IO ()
logO filePath program = do
compGraph <- runO' program
writeFile filePath (showGraph compGraph)
return ()
where showGraph g = showWith g showVertex showArc
showVertex Root = ("root","")
showVertex v = (showCompStmts v ++ "\nwith stack "
++ (show . equStack . head . equations $ v), "")
showArc _ = ""
showCompStmts = showCompStmts' . equations
showCompStmts' [e] = show e
showCompStmts' es = foldl (\acc e-> acc ++ show e ++ ", ") "{" (init es)
++ show (last es) ++ "}"
hPutStrList :: (Show a) => Handle -> [a] -> IO()
hPutStrList h [] = hPutStrLn h ""
hPutStrList h (c:cs) = do {hPutStrLn h (show c); hPutStrList h cs}
data PushMode = Vanilla | Drop | Truncate
pushMode :: IORef PushMode
pushMode = unsafePerformIO $ newIORef Vanilla
setPushMode :: PushMode -> IO ()
setPushMode = writeIORef pushMode
getPushMode :: PushMode
getPushMode = unsafePerformIO $ readIORef pushMode
parseArgs :: [String] -> PushMode
parseArgs [] = Truncate
parseArgs (arg:_) = case arg of
"--PushVanilla" -> Vanilla
"--PushDrop" -> Drop
"--PushTruncate" -> Truncate
_ -> error ("unknown option " ++ arg)
debugSession :: [(String,String)] -> CompGraph -> IO ()
debugSession slices tree
= do createDirectoryIfMissing True ".Hoed/wwwroot/css"
writeFile ".Hoed/wwwroot/debug.css" stylesheet
treeRef <- newIORef tree
startGUI defaultConfig
{ jsPort = Just 10000
, jsStatic = Just "./.Hoed/wwwroot"
} (demoGUI slices treeRef)
stylesheet
= "div {\n"
++ " padding:0;\n"
++ " margin:0;\n"
++ "}\n"
++ ".buttons {\n"
++ " float:top;\n"
++ " height:50vh;\n"
++ " overflow-y: scroll;\n"
++ " overflow-x: hidden;\n"
++ "}\n"
++ ".nowrap {\n"
++ " white-space: nowrap;\n"
++ "}\n"
++ ".odd {\n"
++ " background-color: lightgray;\n"
++ " padding: 10px 0;\n"
++ "}\n"
++ ".even {\n"
++ " background-color: white;\n"
++ " padding: 10px 0;\n"
++ "}\n"