module Debug.Hoed
(
observe
, runO
, printO
, testO
, runOwith
, HoedOptions(..)
, defaultHoedOptions
, runOwp
, printOwp
, testOwp
, Propositions(..)
, PropType(..)
, Proposition(..)
, mkProposition
, ofType
, withSignature
, sizeHint
, withTestGen
, TestGen(..)
, PropositionType(..)
, Module(..)
, Signature(..)
, ParEq(..)
, (===)
, runOstore
, conAp
, HoedAnalysis(..)
, runO'
, judge
, unjudgedCharacterCount
, CompTree
, Vertex(..)
, CompStmt(..)
, Judge(..)
, Verbosity(..)
, logO
, logOwp
, traceOnly
, UnevalHandler(..)
, Observable(..)
, (<<)
, thunk
, send
, observeOpaque
, observeBase
, constrainBase
, debugO
, CDS
, Generic
) where
import Control.DeepSeq
import Control.Monad
import qualified Data.Vector.Generic as VG
import Debug.Hoed.CompTree
import Debug.Hoed.Console
import Debug.Hoed.Observe
import Debug.Hoed.Prop
import Debug.Hoed.Render
import Debug.Hoed.Serialize
import Debug.Hoed.Util
import Data.Foldable (toList)
import Data.IORef
import Prelude hiding (Right)
import System.Clock
import System.Console.Terminal.Size
import System.Directory (createDirectoryIfMissing)
import System.IO
import System.IO.Unsafe
import GHC.Generics
import Data.Graph.Libgraph
runOnce :: IO ()
runOnce = do
f <- readIORef firstRun
if f
then writeIORef firstRun False
else 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
; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"
; ourCatchAllIO (do { _ <- program ; return () })
(hPutStrLn stderr . errorMsg)
; res <- endEventStream
; initUniq
; return res
}
runO :: IO a -> IO ()
runO program = do
window <- size
let w = maybe (prettyWidth defaultHoedOptions) width window
runOwith defaultHoedOptions{prettyWidth=w, verbose=Verbose} program
runOwith :: HoedOptions -> IO a -> IO ()
runOwith options program = do
HoedAnalysis{..} <- runO' options program
debugSession hoedTrace hoedCompTree []
return ()
runOstore :: String -> IO a -> IO ()
runOstore tag program = do
HoedAnalysis{..} <- runO' defaultHoedOptions{verbose=Silent} program
storeTree (treeFilePath ++ tag) hoedCompTree
storeTrace (traceFilePath ++ tag) hoedTrace
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
HoedAnalysis{..} <- runO' defaultHoedOptions{verbose=Verbose} program
let compTree' = hoedCompTree
debugSession hoedTrace compTree' 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)
printOwp :: (Show a) => [Propositions] -> a -> IO ()
printOwp ps expr = runOwp ps (print expr)
traceOnly :: IO a -> IO ()
traceOnly program = do
_ <- debugO program
return ()
data HoedAnalysis = HoedAnalysis
{ hoedTrace :: Trace
, hoedCompTree :: CompTree
}
data HoedOptions = HoedOptions
{ verbose :: Verbosity
, prettyWidth :: Int
}
defaultHoedOptions :: HoedOptions
defaultHoedOptions = HoedOptions Silent 110
runO' :: HoedOptions -> IO a -> IO HoedAnalysis
runO' HoedOptions{..} program = let ?statementWidth = prettyWidth in do
hSetBuffering stderr NoBuffering
createDirectoryIfMissing True ".Hoed/"
tProgram <- stopWatch
condPutStrLn verbose "=== program output ===\n"
events <- debugO program
programTime <- tProgram
condPutStrLn verbose $ "\n=== program terminated (" ++ show programTime ++ ") ==="
#if defined(DEBUG)
writeFile ".Hoed/Events" (unlines . map show $ toList events)
#endif
condPutStrLn verbose "\n=== Statistics ===\n"
condPutStrLn verbose $ show (VG.length events) ++ " events"
condPutStrLn verbose"Please wait while the computation tree is constructed..."
tTrace <- stopWatch
ti <- traceInfo verbose events
traceTime <- tTrace
condPutStrLn verbose $ " " ++ show traceTime
let cdss = eventsToCDS events
eqs = renderCompStmts cdss
let !ds = force $ dependencies ti
ct = mkCompTree eqs ds
condPutStr verbose "Calculating the nodes of the computation graph"
tCds <- stopWatch
forM_ (zip [0..] cdss) $ \(i,x) -> do
evaluate (force x)
when (isPowerOf 2 i) $ condPutStr verbose "."
cdsTime <- tCds
condPutStrLn verbose $ " " ++ show cdsTime
condPutStr verbose "Rendering the nodes of the computation graph"
tEqs <- stopWatch
forM_ (zip [0..] eqs) $ \(i,x) -> do
evaluate (case stmtDetails x of
StmtCon c _ -> seq c ()
StmtLam args res _ -> args `seq` res `seq` ())
when (isPowerOf 2 i) $ condPutStr verbose "."
eqsTime <- tEqs
condPutStrLn verbose $ " " ++ show eqsTime
#if defined(DEBUG)
writeFile ".Hoed/Eqs" (unlines . map show $ toList eqs)
writeFile ".Hoed/Deps" (unlines . map show $ toList ds)
#endif
#if defined(TRANSCRIPT)
writeFile ".Hoed/Transcript" (getTranscript (toList events) ti)
#endif
let n = length eqs
b = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) (length . leafs $ ct))
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)"
let compTime = traceTime + cdsTime + eqsTime
condPutStrLn verbose $ "\n=== Debug Session (" ++ show compTime ++ ") ===\n"
return $ HoedAnalysis events ct
isPowerOf n 0 = False
isPowerOf n k | n == k = True
| k `mod` n == 0 = isPowerOf n (k `div` n)
| otherwise = False
logO :: FilePath -> IO a -> IO ()
logO filePath program = do
HoedAnalysis{..} <- runO' defaultHoedOptions{verbose=Verbose} program
writeFile filePath (showGraph hoedCompTree)
return ()
logOwp :: UnevalHandler -> FilePath -> [Propositions] -> IO a -> IO ()
logOwp handler filePath properties program = do
HoedAnalysis{..} <- runO' defaultHoedOptions{verbose=Verbose} program
hPutStrLn stderr "\n=== Evaluating assigned properties ===\n"
compTree' <- judgeAll handler unjudgedCharacterCount hoedTrace properties hoedCompTree
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
#if __GLASGOW_HASKELL__ >= 710
instance Observable a where
observer = observeOpaque "<?>"
constrain _ _ = error "constrained by untraced value"
#endif