From 4fba97ba3a19c725714b5d55721368657e41daa3 Mon Sep 17 00:00:00 2001
From: Yann Herklotz <git@yannherklotz.com>
Date: Sat, 25 May 2019 21:20:51 +0100
Subject: Add synthesis fails to fuzzer

---
 src/VeriFuzz/Fuzz.hs   | 16 ++++++++++++++++
 src/VeriFuzz/Reduce.hs |  1 +
 2 files changed, 17 insertions(+)

diff --git a/src/VeriFuzz/Fuzz.hs b/src/VeriFuzz/Fuzz.hs
index f85ab1f..3f6a14b 100644
--- a/src/VeriFuzz/Fuzz.hs
+++ b/src/VeriFuzz/Fuzz.hs
@@ -132,6 +132,13 @@ passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get
     passed _                          = False
     toSynth (SynthStatus s _ _) = s
 
+failedSynthesis :: MonadSh m => Fuzz m [SynthTool]
+failedSynthesis = fmap toSynth . filter failed . _fuzzSynthStatus <$> get
+  where
+    failed (SynthStatus _ (Fail SynthFail) _) = True
+    failed _                                  = False
+    toSynth (SynthStatus s _ _) = s
+
 make :: MonadSh m => FilePath -> m ()
 make f = liftSh $ do
     mkdir_p f
@@ -210,7 +217,9 @@ failEquivWithIdentity = filter withIdentity . _fuzzSynthResults <$> get
 reduction :: (MonadSh m) => SourceInfo -> Fuzz m ()
 reduction src = do
     fails <- failEquivWithIdentity
+    synthFails <- failedSynthesis
     _     <- liftSh $ mapM red fails
+    _     <- liftSh $ mapM redSynth synthFails
     return ()
   where
     red (SynthResult a b _ _) = do
@@ -220,6 +229,13 @@ reduction src = do
             writefile (fromText ".." </> dir <.> "v") $ genSource s
             return s
         where dir = fromText $ "reduce_" <> toText a <> "_" <> toText b
+    redSynth (SynthStatus a _ _) = do
+        make dir
+        pop dir $ do
+            s <- reduceSynthesis a src
+            writefile (fromText ".." </> dir <.> "v") $ genSource s
+            return s
+        where dir = fromText $ "reduce_" <> toText a
 
 titleRun
     :: (MonadIO m, MonadSh m) => Text -> Fuzz m a -> Fuzz m (NominalDiffTime, a)
diff --git a/src/VeriFuzz/Reduce.hs b/src/VeriFuzz/Reduce.hs
index 0ecde3f..b025a42 100644
--- a/src/VeriFuzz/Reduce.hs
+++ b/src/VeriFuzz/Reduce.hs
@@ -17,6 +17,7 @@ module VeriFuzz.Reduce
     ( -- $strategy
       reduceWithScript
     , reduceSynth
+    , reduceSynthesis
     , reduce
     , reduce_
     , Replacement(..)
-- 
cgit