Skip to content

Commit a81bdb9

Browse files
robdockinsrobdockins
committed
Use HTML-like tables instead of graph clusters for
displaying verification conditions of method specs. This reduces clutter in the graph and produces more readable output.
1 parent b147d4e commit a81bdb9

File tree

1 file changed

+114
-54
lines changed

1 file changed

+114
-54
lines changed

‎verif-viewer/tools/VerifViewer.hs

+114-54
Original file line numberDiff line numberDiff line change
@@ -7,13 +7,15 @@ import Control.Monad
77
import Data.Aeson
88
import Data.Aeson.Types (Parser)
99
import qualified Data.Aeson.Types as AE
10+
import Data.Maybe (isJust)
1011
import Data.Map (Map)
1112
import qualified Data.Map as Map
1213
import Data.Foldable (toList)
1314
import Data.Text (Text)
1415
import qualified Data.Text as T
1516
import qualified Data.Text.Lazy as TL
1617
import qualified Data.Text.Lazy.IO as TL
18+
import qualified Data.Set as Set
1719
import System.IO
1820
import System.Exit (exitFailure)
1921
import System.Environment (getArgs)
@@ -25,111 +27,169 @@ import qualified Data.GraphViz as GV
2527
import qualified Data.GraphViz.Attributes as GV
2628
import qualified Data.GraphViz.Attributes.Complete as GV
2729
import qualified Data.GraphViz.Printing as GV
30+
import qualified Data.GraphViz.Attributes.HTML as HTML
2831

2932
main :: IO ()
3033
main =
3134
do [f,o] <- getArgs
3235
bs <- BS.readFile f
3336
case AT.parseOnly json' bs of
3437
Left msg -> putStrLn msg >> exitFailure
35-
Right v ->
38+
Right v ->
3639
case AE.parse parseNodes v of
3740
AE.Error msg -> putStrLn msg >> exitFailure
3841
AE.Success ns -> handleNodes o ns
3942

4043
handleNodes :: FilePath -> [SummaryNode] -> IO ()
4144
handleNodes o ns = TL.writeFile o (GV.renderDot (GV.toDot dot))
4245
where
43-
dot = GV.graphElemsToDot params nodes edges
46+
dot = GV.graphElemsToDot params nodes uniqEdges
4447

4548
params :: GV.GraphvizParams Integer SummaryNode () Integer SummaryNode
4649
params = GV.defaultParams
4750
{ GV.fmtNode = fmt
48-
, GV.clusterBy = cls
49-
, GV.clusterID = clsID
5051
, GV.globalAttributes =
51-
[ GV.GraphAttrs [ GV.RankDir GV.FromLeft , GV.RankSep [2.0] ]
52-
]
52+
[ GV.GraphAttrs [ GV.RankDir GV.FromLeft , GV.RankSep [2.0] ] ]
5353
}
5454

55+
nodeMap :: Map Integer SummaryNode
56+
nodeMap = Map.fromList [ (summaryNodeId n, n) | n <- ns ]
57+
5558
revMethodDep :: Map Integer Integer
5659
revMethodDep = Map.fromList $
5760
do MethodSummary i s <- ns
5861
t <- methodDeps s
62+
Just (TheoremSummary _ _) <- pure (Map.lookup t nodeMap)
5963
pure (t, i)
6064

61-
clsID :: Integer -> GV.GraphID
62-
clsID = GV.Num . GV.Int . fromInteger
65+
nodes :: [(Integer,SummaryNode)]
66+
nodes = do n <- ns
67+
if isVCGoal (summaryNodeId n) then [] else pure (summaryNodeId n, n)
6368

64-
cls :: (Integer, SummaryNode) -> GV.NodeCluster Integer (Integer, SummaryNode)
65-
cls (i, s@TheoremSummary{})
66-
| Just mth <- Map.lookup i revMethodDep = GV.C mth (GV.N (i,s))
67-
| otherwise = GV.N (i,s)
68-
cls (i, s@MethodSummary{}) = GV.C i (GV.N (i,s))
69+
isVCGoal :: Integer -> Bool
70+
isVCGoal i = isJust (Map.lookup i revMethodDep)
6971

70-
nodes :: [(Integer,SummaryNode)]
71-
nodes = map (\n -> (summaryNodeId n, n)) ns
72+
uniqEdges :: [(Integer,Integer,())]
73+
uniqEdges = Set.toList (Set.fromList edges)
7274

7375
edges :: [(Integer,Integer,())]
7476
edges = do n <- ns
75-
n' <- summaryNodeDeps n
76-
pure (summaryNodeId n,n',())
77+
let i = case n of
78+
TheoremSummary i thm
79+
| Just parent <- Map.lookup i revMethodDep -> parent
80+
_ -> summaryNodeId n
81+
n' <- filter (not . isVCGoal) (summaryNodeDeps n)
82+
pure (i,n',())
7783

7884
fmt :: (Integer, SummaryNode) -> GV.Attributes
7985
fmt (_, TheoremSummary _ s) = fmtThm s
80-
fmt (_, MethodSummary _ s) = fmtMethod s
81-
86+
fmt (_, MethodSummary _ s) = fmtMethod nodeMap s
8287

8388

8489
fmtThm :: TheoremNode -> GV.Attributes
8590
fmtThm thm = [ GV.shape GV.Trapezium
86-
, GV.Tooltip (TL.fromStrict tt)
91+
, GV.Tooltip (TL.fromStrict (thmTooltip thm))
8792
, GV.textLabel (TL.fromStrict lab)
8893
, GV.style GV.filled
89-
, fillcol
94+
, GV.FillColor [GV.toWC (thmColor thm)]
9095
]
91-
where
92-
fillcol =
93-
case thmStatus thm of
94-
TheoremVerified{} -> GV.fillColor GV.Green
95-
TheoremTested{} -> GV.fillColor GV.Yellow
96-
TheoremAdmitted{} -> GV.fillColor GV.Red
9796

98-
lab = T.unlines (status ++ [T.pack (show (thmElapsedTime thm))])
97+
where
98+
lab = T.unlines [thmStatusText thm, T.pack (show (thmElapsedTime thm))]
9999

100-
status = case thmStatus thm of
101-
TheoremVerified sls -> [T.unwords ("verified:" : sls)]
102-
TheoremTested nm -> [T.unwords ["tested:", T.pack (show nm)]]
103-
TheoremAdmitted msg -> ["Admitted!", msg]
104100

105-
tt = T.unlines
101+
fmtMethod :: Map Integer SummaryNode -> MethodNode -> GV.Attributes
102+
fmtMethod nodeMap mn = [ GV.Label (GV.HtmlLabel top), GV.Shape GV.PlainText ]
103+
where
104+
top =
105+
if null subs then
106+
HTML.Table (HTML.HTable Nothing [HTML.CellBorder 0] [ HTML.Cells [main] ])
107+
else
108+
HTML.Table (HTML.HTable Nothing [HTML.CellBorder 0] [ HTML.Cells [main], HTML.Cells [subsTab]])
109+
110+
main = HTML.LabelCell
111+
[ HTML.Title (TL.fromStrict maintt)
112+
, HTML.HRef "#"
113+
, HTML.BGColor fillcol
114+
]
115+
(HTML.Text [ HTML.Str (TL.fromStrict maintext) ])
116+
117+
subsTab :: HTML.Cell
118+
subsTab = HTML.LabelCell [] (HTML.Table (HTML.HTable Nothing [HTML.Border 0, HTML.CellBorder 1] [HTML.Cells subs]))
119+
120+
vcs = do d <- methodDeps mn
121+
Just (TheoremSummary i thm) <- pure (Map.lookup d nodeMap)
122+
pure (i,thm)
123+
124+
subs :: [HTML.Cell]
125+
subs = map (uncurry mkSub) vcs
126+
127+
mkSub :: Integer -> TheoremNode -> HTML.Cell
128+
mkSub i thm = HTML.LabelCell attrs (HTML.Text [ HTML.Str (TL.fromStrict (T.pack (show (thmElapsedTime thm)))) ])
129+
where
130+
attrs =
131+
[ HTML.BGColor (thmColor thm)
132+
, HTML.Title (TL.fromStrict (thmStatusText thm <> "\n" <> thmTooltip thm))
133+
, HTML.HRef "#"
134+
]
135+
136+
fillcol = statusColor $
137+
foldr (<>) (methodToStatus mn) (map (thmToStatus . snd) vcs)
138+
139+
maintext =
140+
T.unlines
141+
[ methodName mn
142+
, T.pack (show (methodElapsedtime mn))
143+
]
144+
maintt = methodLoc mn
145+
146+
147+
data Status = Proved | Tested | Assumed
148+
149+
statusColor :: Status -> GV.Color
150+
statusColor Proved = GV.X11Color GV.Green
151+
statusColor Tested = GV.X11Color GV.Yellow
152+
statusColor Assumed = GV.X11Color GV.Red
153+
154+
instance Semigroup Status where
155+
Assumed <> _ = Assumed
156+
_ <> Assumed = Assumed
157+
Tested <> Proved = Tested
158+
Proved <> Tested = Tested
159+
Tested <> Tested = Tested
160+
Proved <> Proved = Proved
161+
162+
thmToStatus :: TheoremNode -> Status
163+
thmToStatus thm = case thmStatus thm of
164+
TheoremVerified{} -> Proved
165+
TheoremTested{} -> Tested
166+
TheoremAdmitted{} -> Assumed
167+
168+
methodToStatus :: MethodNode -> Status
169+
methodToStatus mn = case methodStatus mn of
170+
MethodAssumed -> Assumed
171+
MethodVerified -> Proved
172+
173+
thmColor :: TheoremNode -> GV.Color
174+
thmColor = statusColor . thmToStatus
175+
176+
thmStatusText :: TheoremNode -> Text
177+
thmStatusText thm = T.unlines $
178+
case thmStatus thm of
179+
TheoremVerified sls -> [T.unwords ("verified:" : sls)]
180+
TheoremTested nm -> [T.unwords ["tested:", T.pack (show nm)]]
181+
TheoremAdmitted msg -> ["Admitted!", msg]
182+
183+
184+
thmTooltip :: TheoremNode -> Text
185+
thmTooltip thm = T.unlines
106186
([ thmReason thm
107187
, thmLoc thm
108188
] ++
109189
case thmPLoc thm of
110190
Nothing -> []
111191
Just (fn,l) -> [ fn <> " " <> l ])
112192

113-
fmtMethod :: MethodNode -> GV.Attributes
114-
fmtMethod mn = [ GV.textLabel (TL.fromStrict lab)
115-
, GV.Tooltip (TL.fromStrict tt)
116-
, GV.style GV.filled
117-
, fillcol
118-
]
119-
where
120-
fillcol =
121-
case methodStatus mn of
122-
MethodVerified -> GV.fillColor GV.Green
123-
MethodAssumed -> GV.fillColor GV.Red
124-
125-
lab = T.unlines
126-
[ methodName mn
127-
, T.pack (show (methodElapsedtime mn))
128-
]
129-
tt = T.unlines
130-
[ methodLoc mn
131-
]
132-
133193

134194
parseNodes :: Value -> Parser [SummaryNode]
135195
parseNodes = withArray "summary nodes" (mapM parseNode . toList)
@@ -151,7 +211,7 @@ parseMethodNode o =
151211
parseMethodStatus o <*>
152212
parseDeps o <*>
153213
o .: "elapsedtime"
154-
214+
155215
parseMethodStatus :: Object -> Parser MethodStatus
156216
parseMethodStatus o =
157217
do st <- o .: "status"

0 commit comments

Comments
 (0)