module Debug.Vampire.Analyze (structFor, valueFor, toGraph, viewExpr) where
import Debug.Vampire.Data
import Debug.Vampire.Trace
import Control.DeepSeq
import Data.IORef
import Data.Graph.Inductive
import Data.GraphViz hiding (parse)
import Data.DList (singleton, fromList, toList)
import Control.Arrow
import Control.Monad.RWS
instance Labellable () where
toLabelValue = const (toLabelValue "")
structFor :: (Show a, NFData a) => ((?vCtx::IORef ExprStruct') => () -> a) -> IO ExprStruct
structFor d = do
let struct' = (let ?vCtx = vNewExprStruct "toplevel" in d () `deepseq` ?vCtx)
struct <- readIORef struct' >>= resolve
return $ case children struct of
full:_ -> full
[] -> ExprStruct "" Nothing []
valueFor :: (Show a, NFData a) => ((?vCtx::IORef ExprStruct') => () -> a) -> a
valueFor d = let ?vCtx = vNewExprStruct "toplevel" in d ()
labelFor :: ExprStruct -> String
labelFor (ExprStruct expr (Just val) _) = expr ++ " = " ++ val
labelFor (ExprStruct expr Nothing _) = expr ++ " = Unevaluated"
toGraph :: ExprStruct -> Gr String ()
toGraph t = uncurry mkGraph . (toList *** toList) . snd $ evalRWS (go t) () [1..]
where go e@(ExprStruct _ _ ns) = do
i <- state $ head &&& tail
es <- forM ns $ go >=> \j -> return (i, j, ())
tell (singleton (i, labelFor e), fromList es)
return i
viewExpr :: (Show a, NFData a) => ((?vCtx::IORef ExprStruct') => () -> a) -> IO ()
viewExpr = structFor >=> preview . toGraph