Update simulator with Result type

1 files changed, 57 insertions, 15 deletions

diff --git a/src/VeriFuzz/Sim/Internal.hs b/src/VeriFuzz/Sim/Internal.hs
index 3ff2924..8327ad8 100644
--- a/src/VeriFuzz/Sim/Internal.hs
+++ b/src/VeriFuzz/Sim/Internal.hs
@@ -10,10 +10,14 @@ Portability : POSIX
 Class of the simulator and the synthesize tool.
 -}
 
+{-# LANGUAGE DeriveFunctor #-}
+
 module VeriFuzz.Sim.Internal
-    ( Tool(..)
+    ( ResultSh
+    , Tool(..)
     , Simulator(..)
     , Synthesiser(..)
+    , Failed(..)
     , rootPath
     , timeout
     , timeout_
@@ -22,6 +26,10 @@ module VeriFuzz.Sim.Internal
     , echoP
     , logger
     , logger_
+    , execute
+    , execute_
+    , (<?>)
+    , annotate
     )
 where
 
@@ -34,8 +42,10 @@ import qualified Data.Text             as T
 import           Data.Time.LocalTime   (getZonedTime)
 import           Prelude               hiding (FilePath)
 import           Shelly
+import           Shelly.Lifted         (MonadSh, liftSh)
 import           System.FilePath.Posix (takeBaseName)
 import           VeriFuzz.Internal
+import           VeriFuzz.Result
 import           VeriFuzz.Verilog.AST
 
 -- | Tool class.
@@ -43,22 +53,40 @@ class Tool a where
   toText :: a -> Text
 
 -- | Simulation type class.
-class (Tool a) => Simulator a where
+class Tool a => Simulator a where
   runSim :: a             -- ^ Simulator instance
          -> SourceInfo       -- ^ Run information
          -> [ByteString]  -- ^ Inputs to simulate
-         -> Sh ByteString -- ^ Returns the value of the hash at the output of the testbench.
+         -> ResultSh ByteString -- ^ Returns the value of the hash at the output of the testbench.
   runSimWithFile :: a
                  -> FilePath
                  -> [ByteString]
-                 -> Sh ByteString
+                 -> ResultSh ByteString
+
+data Failed = EmptyFail
+            | EquivFail
+            | SimFail
+            | SynthFail
+            deriving (Eq, Show)
+
+instance Semigroup Failed where
+    EmptyFail <> a = a
+    b <> _ = b
+
+instance Monoid Failed where
+    mempty = EmptyFail
 
 -- | Synthesiser type class.
-class (Tool a) => Synthesiser a where
+class Tool a => Synthesiser a where
   runSynth :: a        -- ^ Synthesiser tool instance
            -> SourceInfo  -- ^ Run information
            -> FilePath -- ^ Output verilog file for the module
-           -> Sh ()    -- ^ does not return any values
+           -> ResultSh ()    -- ^ does not return any values
+
+-- | Type synonym for a 'ResultT' that will be used throughout 'VeriFuzz'. This
+-- has instances for 'MonadSh' and 'MonadIO' if the 'Monad' it is parametrised
+-- with also has those instances.
+type ResultSh = ResultT Failed Sh
 
 rootPath :: Sh FilePath
 rootPath = do
@@ -79,7 +107,7 @@ bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0
 {-# INLINE bsToI #-}
 
 noPrint :: Sh a -> Sh a
-noPrint = print_stdout False . print_stderr False
+noPrint = liftSh . print_stdout False . print_stderr False
 {-# INLINE noPrint #-}
 
 echoP :: Text -> Sh ()
@@ -90,16 +118,30 @@ echoP t = do
     where bname = T.pack . takeBaseName . T.unpack . toTextIgnore
 
 logger :: FilePath -> Text -> Sh a -> Sh a
-logger fp name = log_stderr_with (l "_log.stderr.txt")
-    . log_stdout_with (l "_log.txt")
+logger fp name = log_stderr_with (l "_stderr.log") . log_stdout_with (l ".log")
   where
     l s t = appendFile (file s) (T.unpack t) >> appendFile (file s) "\n"
     file s = T.unpack (toTextIgnore $ fp </> fromText name) <> s
 
 logger_ :: FilePath -> Text -> Sh a -> Sh ()
-logger_ fp name =
-    void . log_stderr_with (l "_log.stderr.txt") . log_stdout_with
-        (l "_log.txt")
-  where
-    l s t = appendFile (file s) (T.unpack t) >> appendFile (file s) "\n"
-    file s = T.unpack (toTextIgnore $ fp </> fromText name) <> s
+logger_ fp name = void . logger fp name
+
+execute
+    :: (MonadSh m, Monad m, Monoid a)
+    => a
+    -> FilePath
+    -> Text
+    -> FilePath
+    -> [Text]
+    -> ResultT a m Text
+execute f dir name e = annotate f . liftSh . logger dir name . timeout e
+
+execute_
+    :: (MonadSh m, Monad m, Monoid a)
+    => a
+    -> FilePath
+    -> Text
+    -> FilePath
+    -> [Text]
+    -> ResultT a m ()
+execute_ a b c d = void . execute a b c d