module Debug.Hoed.Pure
(
observe
, runO
, printO
, testO
, runOwp
, testOwp
, Propositions(..)
, PropType(..)
, Proposition(..)
, PropositionType(..)
, Module(..)
, Signature(..)
, ParEq(..)
, runOstore
, conAp
, runO'
, judge
, unjudgedCharacterCount
, CompTree(..)
, Vertex(..)
, CompStmt(..)
, Judge(..)
, Verbosity(..)
, observeTempl
, observedTypes
, logO
, logOwp
, traceOnly
, UnevalHandler(..)
, Observer(..)
, Observable(..)
, (<<)
, thunk
, nothunk
, send
, observeOpaque
, observeBase
, constrainBase
, debugO
, CDS(..)
, Generic
) where
import Debug.Hoed.Pure.Observe
import Debug.Hoed.Pure.Render
import Debug.Hoed.Pure.EventForest
import Debug.Hoed.Pure.CompTree
import Debug.Hoed.Pure.DemoGUI
import Debug.Hoed.Pure.Prop
import Debug.Hoed.Pure.Serialize
import Paths_Hoed(getDataDir)
import Prelude hiding (Right)
import qualified Prelude
import System.Process(system)
import System.IO
import Data.Maybe
import Control.Monad
import Data.List
import Data.Ord
import Data.Char
import System.Environment
import System.Directory(createDirectoryIfMissing)
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)
runOnce :: IO ()
runOnce = do
f <- readIORef firstRun
case f of True -> writeIORef firstRun False
False -> error "It is best not to run Hoed more that once (maybe you want to restart GHCI?)"
firstRun :: IORef Bool
firstRun = unsafePerformIO $ newIORef True
debugO :: IO a -> IO Trace
debugO program =
do { runOnce
; initUniq
; startEventStream
; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"
; ourCatchAllIO (do { program ; return () })
(hPutStrLn stderr . errorMsg)
; endEventStream
}
runO :: IO a -> IO ()
runO program = do
(trace,traceInfo,compTree,frt) <- runO' Verbose program
debugSession trace traceInfo compTree frt []
return ()
runOstore :: String -> IO a -> IO ()
runOstore tag program = do
(trace,traceInfo,compTree,frt) <- runO' Silent program
storeTree (treeFilePath ++ tag) compTree
storeTrace (traceFilePath ++ tag) trace
testO :: Show a => (a->Bool) -> a -> IO ()
testO p x = runO $ putStrLn $ if (p x) then "Passed 1 test."
else " *** Failed! Falsifiable: " ++ show x
runOwp :: [Propositions] -> IO a -> IO ()
runOwp ps program = do
(trace,traceInfo,compTree,frt) <- runO' Verbose program
let compTree' = compTree
debugSession trace traceInfo compTree' frt ps
return ()
testOwp :: Show a => [Propositions] -> (a->Bool) -> a -> IO ()
testOwp ps p x = runOwp ps $ putStrLn $
if (p x) then "Passed 1 test."
else " *** Failed! Falsifiable: " ++ show x
printO :: (Show a) => a -> IO ()
printO expr = runO (print expr)
traceOnly :: IO a -> IO ()
traceOnly program = do
debugO program
return ()
data Verbosity = Verbose | Silent
condPutStrLn :: Verbosity -> String -> IO ()
condPutStrLn Silent _ = return ()
condPutStrLn Verbose msg = hPutStrLn stderr msg
runO' :: Verbosity -> IO a -> IO (Trace,TraceInfo,CompTree,EventForest)
runO' verbose program = do
createDirectoryIfMissing True ".Hoed/"
condPutStrLn verbose "=== program output ===\n"
events <- debugO program
condPutStrLn verbose"\n=== program terminated ==="
condPutStrLn verbose"Please wait while the computation tree is constructed..."
let cdss = eventsToCDS events
let cdss1 = rmEntrySet cdss
let cdss2 = simplifyCDSSet cdss1
let eqs = renderCompStmts cdss2
let frt = mkEventForest events
ti = traceInfo (reverse events)
ds = dependencies ti
ct = mkCompTree eqs ds
writeFile ".Hoed/Events" (unlines . map show . reverse $ events)
#if defined(TRANSCRIPT)
writeFile ".Hoed/Transcript" (getTranscript events ti)
#endif
condPutStrLn verbose "\n=== Statistics ===\n"
let e = length events
n = length eqs
b = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) (length . leafs $ ct))
condPutStrLn verbose $ show e ++ " events"
condPutStrLn verbose $ show n ++ " computation statements"
condPutStrLn verbose $ show ((length . vertices $ ct) 1) ++ " nodes + 1 virtual root node in the computation tree"
condPutStrLn verbose $ show (length . arcs $ ct) ++ " edges in computation tree"
condPutStrLn verbose $ "computation tree has a branch factor of " ++ show b ++ "(i.e the average number of children of non-leaf nodes)"
condPutStrLn verbose "\n=== Debug Session ===\n"
return (events, ti, ct, frt)
logO :: FilePath -> IO a -> IO ()
logO filePath program = do
(_,_,compTree,_) <- runO' Verbose program
writeFile filePath (showGraph compTree)
return ()
where showGraph g = showWith g showVertex showArc
showVertex RootVertex = ("\".\"","shape=none")
showVertex v = ("\"" ++ (escape . showCompStmt) v ++ "\"", "")
showArc _ = ""
showCompStmt = show . vertexStmt
logOwp :: UnevalHandler -> FilePath -> [Propositions] -> IO a -> IO ()
logOwp handler filePath properties program = do
(trace,traceInfo,compTree,frt) <- runO' Verbose program
hPutStrLn stderr "\n=== Evaluating assigned properties ===\n"
compTree' <- judgeAll handler unjudgedCharacterCount trace properties compTree
writeFile filePath (showGraph compTree')
return ()
where showGraph g = showWith g showVertex showArc
showVertex RootVertex = ("root","")
showVertex v = ("\"" ++ (escape . showCompStmt) v ++ "\"", "")
showArc _ = ""
showCompStmt s = (show . vertexJmt) s ++ ": " ++ (show . vertexStmt) s
debugSession :: Trace -> TraceInfo -> CompTree -> EventForest -> [Propositions] -> IO ()
debugSession trace traceInfo tree frt ps
= do createDirectoryIfMissing True ".Hoed/wwwroot/css"
dataDir <- getDataDir
system $ "cp " ++ dataDir ++ "/img/*png .Hoed/wwwroot/"
system $ "cp " ++ dataDir ++ "/img/*gif .Hoed/wwwroot/"
startGUI defaultConfig
{ jsPort = Just 10000
, jsStatic = Just "./.Hoed/wwwroot"
} (guiMain trace tree frt ps)