quickcheck narrowing also shows potential counterexamples

--- a/src/HOL/Tools/Quickcheck/Narrowing_Engine.hs	Wed Nov 30 09:21:09 2011 +0100
+++ b/src/HOL/Tools/Quickcheck/Narrowing_Engine.hs	Wed Nov 30 09:21:11 2011 +0100
@@ -37,10 +37,10 @@
        Left (ErrorCall ('\0':p)) -> unknown (map fromEnum p)
        Left e -> throw e);
 
-answer :: Bool -> (Bool -> IO b) -> (Pos -> IO b) -> IO b;
-answer a known unknown =
+answer :: Bool -> Bool -> (Bool -> IO b) -> (Pos -> IO b) -> IO b;
+answer potential a known unknown =
   Control.Exception.catch (answeri a known unknown) 
-    (\ (PatternMatchFail _) -> known True);
+    (\ (PatternMatchFail _) -> known (not potential));
 
 -- Refute
 
@@ -50,14 +50,15 @@
 report :: Result -> [Generated_Code.Narrowing_term] -> IO Int;
 report r xs = putStrLn ("SOME (" ++ (str_of_list $ zipWith ($) (showArgs r) xs) ++ ")") >> hFlush stdout >> exitWith ExitSuccess;
 
-eval :: Bool -> (Bool -> IO a) -> (Pos -> IO a) -> IO a;
-eval p k u = answer p (\p -> answer p k u) u;
+eval :: Bool -> Bool -> (Bool -> IO a) -> (Pos -> IO a) -> IO a;
+eval potential p k u = answer potential p (\p -> answer potential p k u) u;
 
-ref :: Result -> [Generated_Code.Narrowing_term] -> IO Int;
-ref r xs = eval (apply_fun r xs) (\res -> if res then return 1 else report r xs) (\p -> sumMapM (ref r) 1 (refineList xs p));
+ref :: Bool -> Result -> [Generated_Code.Narrowing_term] -> IO Int;
+ref potential r xs = eval potential (apply_fun r xs) (\res -> if res then return 1 else report r xs)
+  (\p -> sumMapM (ref potential r) 1 (refineList xs p));
           
-refute :: Result -> IO Int;
-refute r = ref r (args r);
+refute :: Bool -> Result -> IO Int;
+refute potential r = ref potential r (args r);
 
 sumMapM :: (a -> IO Int) -> Int -> [a] -> IO Int;
 sumMapM f n [] = return n;
@@ -106,12 +107,12 @@
 
 -- Top-level interface
 
-depthCheck :: Testable a => Int -> a -> IO ();
-depthCheck d p =
-  (refute $ run (const p) 0 d) >> putStrLn ("NONE") >> hFlush stdout;
+depthCheck :: Testable a => Bool -> Int -> a -> IO ();
+depthCheck potential d p =
+  (refute potential $ run (const p) 0 d) >> putStrLn ("NONE") >> hFlush stdout;
 
-smallCheck :: Testable a => Int -> a -> IO ();
-smallCheck d p = mapM_ (`depthCheck` p) [0..d] >> putStrLn ("NONE") >> hFlush stdout;
+smallCheck :: Testable a => Bool -> Int -> a -> IO ();
+smallCheck potential d p = mapM_ (\d -> depthCheck potential d p) [0..d] >> putStrLn ("NONE") >> hFlush stdout;
 
 }
 

--- a/src/HOL/Tools/Quickcheck/PNF_Narrowing_Engine.hs	Wed Nov 30 09:21:09 2011 +0100
+++ b/src/HOL/Tools/Quickcheck/PNF_Narrowing_Engine.hs	Wed Nov 30 09:21:11 2011 +0100
@@ -56,10 +56,10 @@
        Left (ErrorCall ('\0':p)) -> unknown (map fromEnum p)
        Left e -> throw e
 
-answer :: Bool -> (Bool -> IO b) -> (Pos -> IO b) -> IO b;
-answer a known unknown =
+answer :: Bool -> Bool -> (Bool -> IO b) -> (Pos -> IO b) -> IO b;
+answer potential a known unknown =
   Control.Exception.catch (answeri a known unknown) 
-    (\ (PatternMatchFail _) -> known True)
+    (\ (PatternMatchFail _) -> known (not potential))
 
 --  Proofs and Refutation
 
@@ -153,20 +153,20 @@
 
 -- refute
 
-refute :: ([Generated_Code.Narrowing_term] -> Bool) -> Int -> QuantTree -> IO QuantTree
-refute exec d t = ref t
+refute :: ([Generated_Code.Narrowing_term] -> Bool) -> Bool -> Int -> QuantTree -> IO QuantTree
+refute exec potential d t = ref t
   where
     ref t =
       let path = find t in
         do
-          t' <- answer (exec (termListOf [] path)) (\b -> return (updateNode path (Eval b) t))
+          t' <- answer potential (exec (termListOf [] path)) (\b -> return (updateNode path (Eval b) t))
             (\p -> return (if length p < d then refineTree path p t else updateNode path unknown t));
           case evalOf t' of
             UnknownValue True -> ref t'
             _ -> return t'
 
-depthCheck :: Int -> Generated_Code.Property -> IO ()
-depthCheck d p = refute (checkOf p) d (treeOf 0 p) >>= (\t -> 
+depthCheck :: Bool -> Int -> Generated_Code.Property -> IO ()
+depthCheck potential d p = refute (checkOf p) potential d (treeOf 0 p) >>= (\t -> 
   case evalOf t of
    Eval False -> putStrLn ("SOME (" ++ show (counterexampleOf (reifysOf p) (exampleOf 0 t)) ++ ")")  
    _ -> putStrLn ("NONE"))

--- a/src/HOL/Tools/Quickcheck/narrowing_generators.ML	Wed Nov 30 09:21:09 2011 +0100
+++ b/src/HOL/Tools/Quickcheck/narrowing_generators.ML	Wed Nov 30 09:21:11 2011 +0100
@@ -222,7 +222,7 @@
   let val ({elapsed, ...}, result) = Timing.timing e ()
   in (result, (description, Time.toMilliseconds elapsed)) end
   
-fun value (contains_existentials, (quiet, size)) ctxt cookie (code, value_name) =
+fun value (contains_existentials, ((potential, quiet), size)) ctxt cookie (code, value_name) =
   let
     val (get, put, put_ml) = cookie
     fun message s = if quiet then () else Output.urgent_message s
@@ -242,7 +242,8 @@
           "import System;\n" ^
           "import Narrowing_Engine;\n" ^
           "import Generated_Code;\n\n" ^
-          "main = getArgs >>= \\[size] -> Narrowing_Engine.depthCheck (read size) (Generated_Code.value ())\n\n" ^
+          "main = getArgs >>= \\[potential, size] -> " ^
+          "Narrowing_Engine.depthCheck (read potential) (read size) (Generated_Code.value ())\n\n" ^
           "}\n"
         val code' = prefix "module Generated_Code where {\n\ndata Typerep = Typerep String [Typerep];\n"
           (unprefix "module Generated_Code where {" code)
@@ -257,6 +258,7 @@
         val (result, compilation_time) =
           elapsed_time "Haskell compilation" (fn () => Isabelle_System.bash cmd) 
         val _ = Quickcheck.add_timing compilation_time current_result
+        fun haskell_string_of_bool v = if v then "True" else "False"
         val _ = if Isabelle_System.bash cmd <> 0 then error "Compilation with GHC failed" else ()
         fun with_size k =
           if k > size then
@@ -266,7 +268,8 @@
               val _ = message ("[Quickcheck-narrowing] Test data size: " ^ string_of_int k)
               val _ = current_size := k
               val ((response, _), timing) = elapsed_time ("execution of size " ^ string_of_int k)
-                (fn () => Isabelle_System.bash_output (executable ^ " " ^ string_of_int k))
+                (fn () => Isabelle_System.bash_output
+                  (executable ^ " " ^ haskell_string_of_bool potential  ^ " " ^ string_of_int k))
               val _ = Quickcheck.add_timing timing current_result
             in
               if response = "NONE\n" then
@@ -415,7 +418,8 @@
   let
     fun dest_result (Quickcheck.Result r) = r 
     val opts =
-      (Config.get ctxt Quickcheck.quiet, Config.get ctxt Quickcheck.size)
+      ((Config.get ctxt Quickcheck.potential, Config.get ctxt Quickcheck.quiet),
+        Config.get ctxt Quickcheck.size)
     val thy = Proof_Context.theory_of ctxt
     val t' = fold_rev (fn (x, T) => fn t => HOLogic.mk_all (x, T, t)) (Term.add_frees t []) t
     val pnf_t = make_pnf_term thy t'