From 72ceee9cd751cfa0dc799677325ff2bfbc0f7550 Mon Sep 17 00:00:00 2001
From: Yann Herklotz <git@ymhg.org>
Date: Fri, 19 Apr 2019 00:28:11 +0100
Subject: Extend ResultT and Result with more instances

---
 src/VeriFuzz/Fuzz.hs   | 13 ++++++++-----
 src/VeriFuzz/Result.hs | 42 ++++++++++++++++++++++++++++++++++++++----
 2 files changed, 46 insertions(+), 9 deletions(-)

(limited to 'src/VeriFuzz')

diff --git a/src/VeriFuzz/Fuzz.hs b/src/VeriFuzz/Fuzz.hs
index 5372d94..31503cf 100644
--- a/src/VeriFuzz/Fuzz.hs
+++ b/src/VeriFuzz/Fuzz.hs
@@ -10,7 +10,8 @@ Portability : POSIX
 Environment to run the simulator and synthesisers in a matrix.
 -}
 
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell  #-}
 
 module VeriFuzz.Fuzz
     ( SynthTool(..)
@@ -27,9 +28,11 @@ module VeriFuzz.Fuzz
     )
 where
 
+import           Control.Exception.Lifted         (finally)
 import           Control.Lens
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class        (lift)
+import           Control.Monad.Trans.Control      (MonadBaseControl)
 import           Control.Monad.Trans.Reader       hiding (local)
 import           Control.Monad.Trans.State.Strict
 import           Data.ByteString                  (ByteString)
@@ -200,7 +203,7 @@ timeit a = do
     end <- liftIO getCurrentTime
     return (diffUTCTime end start, result)
 
-synthesis :: MonadSh m => SourceInfo -> Fuzz m ()
+synthesis :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m ()
 synthesis src = do
     synth   <- synthesisers
     results <- liftSh $ mapM exec synth
@@ -230,7 +233,7 @@ make f = liftSh $ do
     mkdir_p f
     cp_r "data" $ f </> fromText "data"
 
-pop :: MonadSh m => FilePath -> m a -> m a
+pop :: (MonadBaseControl IO m, MonadSh m) => FilePath -> m a -> m a
 pop f a = do
     dir <- liftSh pwd
     liftSh $ cd f
@@ -238,7 +241,7 @@ pop f a = do
     liftSh $ cd dir
     return ret
 
-equivalence :: MonadSh m => SourceInfo -> Fuzz m ()
+equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m ()
 equivalence src = do
     yos   <- lift $ asks yosysInstance
     synth <- passedSynthesis
@@ -259,7 +262,7 @@ equivalence src = do
             where
                 dir = fromText $ "equiv_" <> toText a <> "_" <> toText b
 
-fuzz :: (MonadIO m, MonadSh m) => Gen SourceInfo -> Fuzz m FuzzResult
+fuzz :: (MonadBaseControl IO m, MonadIO m, MonadSh m) => Gen SourceInfo -> Fuzz m FuzzResult
 fuzz gen = do
     make "output"
     pop "output" $ do
diff --git a/src/VeriFuzz/Result.hs b/src/VeriFuzz/Result.hs
index 04aa899..c618c77 100644
--- a/src/VeriFuzz/Result.hs
+++ b/src/VeriFuzz/Result.hs
@@ -12,7 +12,12 @@ but to have more control this is reimplemented with the instances that are
 needed in "VeriFuzz".
 -}
 
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 module VeriFuzz.Result
     ( Result(..)
@@ -22,9 +27,13 @@ module VeriFuzz.Result
     )
 where
 
+import           Control.Monad               (liftM)
+import           Control.Monad.Base
 import           Control.Monad.IO.Class
-import           Shelly                 (RunFailed (..), Sh, catch_sh)
-import           Shelly.Lifted          (MonadSh, liftSh)
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Control
+import           Shelly                      (RunFailed (..), Sh, catch_sh)
+import           Shelly.Lifted               (MonadSh, liftSh)
 
 -- | Result type which is equivalent to 'Either' or 'Error'. This is
 -- reimplemented so that there is full control over the 'Monad' definition and
@@ -53,6 +62,9 @@ instance Monad (Result a) where
     Pass a >>= f = f a
     Fail b >>= _ = Fail b
 
+instance MonadBase (Result a) (Result a) where
+    liftBase = id
+
 -- | The transformer for the 'Result' type. This
 newtype ResultT a m b = ResultT { runResultT :: m (Result a b) }
 
@@ -85,9 +97,31 @@ instance (MonadSh m, Monoid a) => MonadSh (ResultT a m) where
         . catch_sh (Pass <$> s)
         $ (const (Fail <$> return mempty) :: RunFailed -> Sh (Result a b))
 
-instance (MonadIO m) => MonadIO (ResultT a m) where
+instance MonadIO m => MonadIO (ResultT a m) where
     liftIO s = ResultT $ Pass <$> liftIO s
 
+instance MonadBase b m => MonadBase b (ResultT a m) where
+    liftBase = liftBaseDefault
+
+instance MonadTrans (ResultT e) where
+    lift m = ResultT $ do
+        a <- m
+        return (Pass a)
+
+instance MonadTransControl (ResultT a) where
+    type StT (ResultT a) b = Result a b
+    liftWith f = ResultT $ liftM return $ f $ runResultT
+    restoreT = ResultT
+    {-# INLINABLE liftWith #-}
+    {-# INLINABLE restoreT #-}
+
+instance MonadBaseControl IO m => MonadBaseControl IO (ResultT a m) where
+    type StM (ResultT a m) b = ComposeSt (ResultT a) m b
+    liftBaseWith = defaultLiftBaseWith
+    restoreM     = defaultRestoreM
+    {-# INLINABLE liftBaseWith #-}
+    {-# INLINABLE restoreM #-}
+
 infix 0 <?>
 
 (<?>) :: (Monad m, Monoid a) => ResultT a m b -> a -> ResultT a m b
-- 
cgit