Ticket #1266: resilient-nodemap.dpatch

File resilient-nodemap.dpatch, 10.3 KB (added by jyasskin@…, 7 years ago)

V1

Line 
1
2New patches:
3
4[Add test framework based on QuickCheck and two tests.
5Jeffrey Yasskin <jyasskin@gmail.com>**20070402234950] {
6hunk ./Setup.hs 1
7+import Distribution.PackageDescription
8hunk ./Setup.hs 3
9-main = defaultMain
10+import Distribution.Simple.LocalBuildInfo
11+import Distribution.Simple.Utils
12+import System.Exit
13+
14+main = defaultMainWithHooks (defaultUserHooks {
15+                              runTests = runTestProgram "test/test.hs" } )
16+
17+runTestProgram program _ _ pkg_descr lbi = do
18+  let bi = maybe emptyBuildInfo libBuildInfo (library pkg_descr)
19+      fbi = (lbi, bi)
20+  ec <- rawSystemPath 3 "runhaskell" $
21+                      ["-i."]
22+                      ++ snd (extensionsToFlags (compilerFlavor $
23+                                                 compiler lbi)
24+                                                (extensions bi))
25+                      ++ [program]
26+  case ec of
27+    ExitSuccess -> putStrLn "PASS"
28+    ExitFailure _ -> putStrLn "FAIL"
29+  exitWith ec
30hunk ./test/test.hs 3
31+import qualified Control.Exception as Exception
32hunk ./test/test.hs 6
33+import Data.List
34+import Data.Maybe (fromJust)
35+import qualified Data.Set as Set
36+import System.Exit
37+import System.Random
38+import Test.QuickCheck
39hunk ./test/test.hs 14
40-main = return ()
41+main = runTests "FGL" defaultConfig
42+       [ evaluate $ prop_emptyIsEmpty (__::Gr Int Int)
43+       , evaluate $ prop_noNodesCountsNodes (__::Gr Integer ())
44+       --, evaluate $ prop_nodeMapProtectsFromDuplicates (__::Gr String String)
45+       --, evaluate $ prop_buildGraphFromArbitraryEdges (__::Gr Integer Integer)
46+       ]
47+
48+__ = undefined
49+
50+-- Use the first parameter to fix the type of graph.
51+prop_emptyIsEmpty :: Graph gr => gr a b -> Bool
52+prop_emptyIsEmpty g = isEmpty (empty `asTypeOf` g)
53+
54+prop_noNodesCountsNodes g labels =
55+  length labels == noNodes (mkGraph (zip [1..] labels) [] `asTypeOf` g)
56+
57+prop_nodeMapProtectsFromDuplicates g_type =
58+  let g1 = empty `asTypeOf` g_type
59+      nm1 = fromGraph g1
60+      (g2, nm2, (num1, lab1)) = insMapNode nm1 "a" g1
61+      (g3, nm3, (num2, lab2)) = insMapNode nm2 "a" g2
62+  in lab1 == lab2 && num1 == num2 && noNodes g3 == 1 {-noNodes g2 == 1-}
63+
64+prop_buildGraphFromArbitraryEdges :: (DynGraph gr, Ord a, Ord b) =>
65+                                     gr a b -> [(a, a, b)] -> Bool
66+prop_buildGraphFromArbitraryEdges g_type edges =
67+  let e = empty `asTypeOf` g_type
68+      g = insMapEdges (fromGraph e) edges e
69+      labEdge (p, s, l) = (fromJust $ lab g p, fromJust $ lab g s, l)
70+  in Set.fromList edges ==
71+     Set.fromList (labEdge `fmap` labEdges g)
72+
73hunk ./test/test.hs 69
74+
75+-- Stuff to make up for QuickCheck being unhelpful for batch testing.
76+runTest :: Config -> Gen Result -> Int -> Int -> [[String]] -> Gen Result
77+runTest config gen ntest nfail stamps
78+  | ntest == configMaxTest config =
79+    return $ Result (Just True) [] []
80+  | nfail == configMaxFail config =
81+    return $ Result Nothing [] []
82+  | otherwise               =
83+      do rnd <- rand
84+         let result = generate (configSize config ntest) rnd gen
85+         case ok result of
86+           Nothing    ->
87+             runTest config gen ntest (nfail+1) stamps
88+           Just True  ->
89+             runTest config gen (ntest+1) nfail (stamp result:stamps)
90+           Just False -> return result
91+
92+runTests name config tests =
93+  do rnd <- newStdGen
94+     results <- mapM runOne (zip3 (unfoldr (Just . split) rnd)
95+                                  [0..] tests)
96+     let errors = length [() | Left _ <- results]
97+         exhausted = length [() | Right (Result {ok=Nothing}) <- results]
98+         failed = length [() | Right (Result {ok=Just False}) <- results]
99+         passed = length [() | Right (Result {ok=Just True}) <- results]
100+     putStrLn (show passed ++ " passed; " ++
101+               show failed ++ " failed; " ++
102+               show exhausted ++ " exhausted their arguments; " ++
103+               show errors ++ " had errors.")
104+     case (failed, exhausted, errors) of
105+       (0,0,0) -> exitWith ExitSuccess
106+       _ -> exitWith (ExitFailure 5)
107+  where
108+  runOne (rnd, i, test) = do
109+    result <- Exception.try $ Exception.evaluate $
110+              generate 0 rnd (runTest config test 0 0 [])
111+    case result of
112+      Left e -> putStrLn (show i ++ ": ERROR " ++ show e)
113+      Right (Result {ok=Nothing}) -> putStrLn (show i ++ ": EXHAUSTED")
114+      Right (Result {ok=Just True}) -> putStrLn (show i ++ ": PASS")
115+      Right (Result {ok=Just False, arguments=args}) ->
116+        do putStrLn (show i ++ ": FAIL")
117+           putStr (unlines args)
118+    return result
119+
120}
121
122[Make NodeMap functions more resilient to messy data.
123Jeffrey Yasskin <jyasskin@gmail.com>**20070404061600] {
124hunk ./Data/Graph/Inductive/NodeMap.hs 7
125-    new, fromGraph, mkNode, mkNode_, mkNodes, mkNodes_, mkEdge, mkEdges,
126+    new, fromGraph, mkNode, mkNewNode, mkNode_,
127+    mkNodes, mkNodes_, mkEdge, mkEdges,
128hunk ./Data/Graph/Inductive/NodeMap.hs 14
129-    insMapNode, insMapNode_, insMapEdge, delMapNode, delMapEdge, insMapNodes,
130-    insMapNodes_, insMapEdges, delMapNodes, delMapEdges, mkMapGraph,
131+    insMapNode, insMapNode_, insMapEdge, safeInsMapEdge,
132+    delMapNode, delMapEdge, insMapNodes,
133+    insMapNodes_, insMapEdges, safeInsMapEdges,
134+    delMapNodes, delMapEdges, mkMapGraph,
135hunk ./Data/Graph/Inductive/NodeMap.hs 33
136+import Data.Either (either)
137hunk ./Data/Graph/Inductive/NodeMap.hs 60
138-mkNode m@(NodeMap mp k) a =
139+mkNode nm a =
140+    case mkNewNode nm a of
141+        (Left lnode, _) -> (lnode, nm)
142+        (Right lnode, nm') -> (lnode, nm')
143+
144+-- | Generate a labelled node from the given label.  If the node has
145+-- already been created, returns it in 'Left', otherwise 'Right'.
146+-- Returns the updated 'NodeMap'.
147+--
148+-- New in fgl-5.5.
149+mkNewNode :: (Ord a) => NodeMap a -> a -> (Either (LNode a) (LNode a), NodeMap a)
150+mkNewNode m@(NodeMap mp k) a =
151hunk ./Data/Graph/Inductive/NodeMap.hs 73
152-       Just i  -> ((i, a), m)
153+       Just i  -> (Left (i, a), m)
154hunk ./Data/Graph/Inductive/NodeMap.hs 76
155-           in ((k, a), m')
156+           in (Right (k, a), m')
157hunk ./Data/Graph/Inductive/NodeMap.hs 108
158+-- | Safe to use on nodes that are already present since fgl-5.5.
159hunk ./Data/Graph/Inductive/NodeMap.hs 110
160-insMapNode m a g =
161-    let (n, m') = mkNode m a
162-    in (insNode n g, m', n)
163+insMapNode m@(NodeMap mp nextNode) label g =
164+    case mkNewNode m label of
165+        (Left lnode, _) -> (g, m, lnode)
166+        (Right lnode, m') -> (insNode lnode g, m', lnode)
167hunk ./Data/Graph/Inductive/NodeMap.hs 125
168+-- | Like insMapEdge but may insert nodes to let the edge insertion succeed.
169+--
170+-- New in fgl-5.5.
171+safeInsMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a, b) -> g a b
172+               -> (g a b, NodeMap a, LEdge b)
173+safeInsMapEdge nm0 (source, target, label) gr0 =
174+    let (gr1, nm1, (sourceNode, _)) = insMapNode nm0 source gr0
175+        (gr2, nm2, (targetNode, _)) = insMapNode nm1 target gr1
176+        lEdge = (sourceNode, targetNode, label)
177+    in (insEdge lEdge gr2, nm2, lEdge)
178+
179+
180hunk ./Data/Graph/Inductive/NodeMap.hs 147
181+-- | Safe to use on nodes that are already present since fgl-5.5.
182hunk ./Data/Graph/Inductive/NodeMap.hs 150
183-    let (ns, m') = mkNodes m as
184-    in (insNodes ns g, m', ns)
185+    let (ns, m') = map' mkNewNode m as
186+    in (insNodes [r | Right r <- ns] g, m', either id id `fmap` ns)
187hunk ./Data/Graph/Inductive/NodeMap.hs 163
188+-- | Like insMapEdges but may insert nodes to let the edge insertion succeed.
189+--
190+-- New in fgl-5.5.
191+safeInsMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a, b)] -> g a b
192+                -> (g a b, NodeMap a, [LEdge b])
193+safeInsMapEdges nm0 edges gr0 =
194+    let (sources, targets, labels) = unzip3 edges
195+        (gr1, nm1, sourceLNodes) = insMapNodes nm0 sources gr0
196+        -- Space leak here. Do we care?
197+        (gr2, nm2, targetLNodes) = insMapNodes nm1 targets gr1
198+        lEdges = zip3 (fst `fmap` sourceLNodes)
199+                      (fst `fmap` targetLNodes)
200+                      labels
201+    in (insEdges lEdges gr2, nm2, lEdges)
202+
203hunk ./Data/Graph/Inductive/NodeMap.hs 271
204+-- | Safe to use on nodes that are already present since fgl-5.5.
205hunk ./Data/Graph/Inductive/NodeMap.hs 275
206+-- | Safe to use on edges with nodes that may not be present since fgl-5.5.
207hunk ./Data/Graph/Inductive/NodeMap.hs 277
208-insMapEdgeM = liftM1 insMapEdge
209+insMapEdgeM edge = liftM1' safeInsMapEdge edge >> return ()
210hunk ./Data/Graph/Inductive/NodeMap.hs 285
211+-- | Safe to use on nodes that are already present since fgl-5.5.
212hunk ./Data/Graph/Inductive/NodeMap.hs 289
213+-- | Safe to use on edges with nodes that may not be present since fgl-5.5.
214hunk ./Data/Graph/Inductive/NodeMap.hs 291
215-insMapEdgesM = liftM1 insMapEdges
216+insMapEdgesM edges = liftM1' safeInsMapEdges edges >> return ()
217hunk ./test/test.hs 17
218-       --, evaluate $ prop_nodeMapProtectsFromDuplicates (__::Gr String String)
219-       --, evaluate $ prop_buildGraphFromArbitraryEdges (__::Gr Integer Integer)
220+       , evaluate $ prop_nodeMapProtectsFromDuplicates (__::Gr String String)
221+       , evaluate $ prop_buildGraphFromArbitraryEdges (__::Gr Integer Integer)
222hunk ./test/test.hs 35
223-  in lab1 == lab2 && num1 == num2 && noNodes g3 == 1 {-noNodes g2 == 1-}
224+  in lab1 == lab2 && num1 == num2 && noNodes g3 == 1
225hunk ./test/test.hs 41
226-      g = insMapEdges (fromGraph e) edges e
227+      (g,_,_) = safeInsMapEdges (fromGraph e) edges e
228}
229
230Context:
231
232[Export UContext, as it is needed in other exported types, too. Fixes Haddock docs.
233sven.panne@aedion.de**20070403101646]
234[Warning police: Removed unused entities. All toplevel entities have a signature now.
235sven.panne@aedion.de**20070403101348]
236[Several bug fixes concerning the behavior of inspection functions
237Martin Erwig <erwig@eecs.oregonstate.edu>**20070330181319
238 like suc and pred in the context of loops.
239 
240]
241[add boilerplate Setup.hs
242Ross Paterson <ross@soi.city.ac.uk>**20060928231525]
243[Remove now unneccesary hiding Data.Array.IO.indices
244Esa Ilari Vuokko <ei@vuokko.info>**20060809144302]
245[Silence warnings.
246Ian Lynagh <igloo@earth.li>**20060730164944]
247[Remove a variable shadowing warning
248Ian Lynagh <igloo@earth.li>**20060730163933]
249[Version June 2006
250Martin Erwig <erwig@eecs.oregonstate.edu>**20060718181211]
251[[project @ 2006-01-18 10:54:19 by simonmar]
252simonmar**20060118105419
253 Stop shadowing a variable
254 
255 (darcs patch from Ian Lynagh)
256]
257[TAG Initial conversion from CVS complete
258John Goerzen <jgoerzen@complete.org>**20060112154129]
259Patch bundle hash:
26074ba448b5f55e62031e5c2e6b1986155c2d09f66