Update simulator with Result type

5 files changed, 111 insertions, 61 deletions

diff --git a/src/VeriFuzz/Sim/Icarus.hs b/src/VeriFuzz/Sim/Icarus.hs
index d9ec05c..8396ff6 100644
--- a/src/VeriFuzz/Sim/Icarus.hs
+++ b/src/VeriFuzz/Sim/Icarus.hs
@@ -34,6 +34,7 @@ import qualified Data.Text                 as T
 import           Numeric                   (readInt)
 import           Prelude                   hiding (FilePath)
 import           Shelly
+import           Shelly.Lifted             (liftSh)
 import           VeriFuzz.Sim.Internal
 import           VeriFuzz.Verilog.AST
 import           VeriFuzz.Verilog.BitVec
@@ -88,7 +89,7 @@ mask = T.replace "x" "0"
 callback :: ByteString -> Text -> ByteString
 callback b t = b <> convert (mask t)
 
-runSimIcarus :: Icarus -> SourceInfo -> [ByteString] -> Sh ByteString
+runSimIcarus :: Icarus -> SourceInfo -> [ByteString] -> ResultSh ByteString
 runSimIcarus sim rinfo bss = do
     let tb = ModDecl
             "main"
@@ -101,12 +102,12 @@ runSimIcarus sim rinfo bss = do
             []
     let newtb     = instantiateMod m tb
     let modWithTb = Verilog [newtb, m]
-    writefile "main.v" $ genSource modWithTb
-    runSimWithFile sim "main.v" bss
+    liftSh . writefile "main.v" $ genSource modWithTb
+    annotate SimFail $ runSimWithFile sim "main.v" bss
     where m = rinfo ^. mainModule
 
-runSimIcarusWithFile :: Icarus -> FilePath -> [ByteString] -> Sh ByteString
-runSimIcarusWithFile sim f _ = do
+runSimIcarusWithFile :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString
+runSimIcarusWithFile sim f _ = annotate SimFail . liftSh $ do
     dir <- pwd
     echoP "Icarus: Compile"
     logger_ dir "icarus" $ run (icarusPath sim) ["-o", "main", toTextIgnore f]
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
diff --git a/src/VeriFuzz/Sim/Quartus.hs b/src/VeriFuzz/Sim/Quartus.hs
index 13b27ae..bed20ed 100644
--- a/src/VeriFuzz/Sim/Quartus.hs
+++ b/src/VeriFuzz/Sim/Quartus.hs
@@ -18,6 +18,7 @@ where
 
 import           Prelude                  hiding (FilePath)
 import           Shelly
+import           Shelly.Lifted            (liftSh)
 import           VeriFuzz.Sim.Internal
 import           VeriFuzz.Verilog.AST
 import           VeriFuzz.Verilog.CodeGen
@@ -34,20 +35,19 @@ instance Synthesiser Quartus where
 defaultQuartus :: Quartus
 defaultQuartus = Quartus Nothing
 
-runSynthQuartus :: Quartus -> SourceInfo -> FilePath -> Sh ()
+runSynthQuartus :: Quartus -> SourceInfo -> FilePath -> ResultSh ()
 runSynthQuartus sim (SourceInfo top src) outf = do
-    dir <- pwd
-    writefile inpf $ genSource src
-    echoP "Running Quartus synthesis"
-    logger_ dir "quartus" $ timeout
-        (exec "quartus_map")
-        [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"]
-    logger_ dir "quartus"
-        $ timeout (exec "quartus_fit") [top, "--part=5CGXFC7D6F27C6"]
-    logger_ dir "quartus"
-        $ timeout (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] -- --formal_verification --tool=conformal
-    cp (fromText "simulation/vcs" </> fromText top <.> "vo") outf
-    echoP "Quartus synthesis done"
+    dir <- liftSh pwd
+    let ex = execute_ SynthFail dir "quartus"
+    liftSh $ do
+        writefile inpf $ genSource src
+        echoP "Running Quartus synthesis"
+    ex (exec "quartus_map") [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"]
+    ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F27C6"]
+    ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"]
+    liftSh $ do
+        cp (fromText "simulation/vcs" </> fromText top <.> "vo") outf
+        echoP "Quartus synthesis done"
   where
     inpf = "rtl.v"
     exec s = maybe (fromText s) (</> fromText s) $ quartusBin sim
diff --git a/src/VeriFuzz/Sim/Vivado.hs b/src/VeriFuzz/Sim/Vivado.hs
index 88328a6..a30af7d 100644
--- a/src/VeriFuzz/Sim/Vivado.hs
+++ b/src/VeriFuzz/Sim/Vivado.hs
@@ -18,6 +18,7 @@ where
 
 import           Prelude                  hiding (FilePath)
 import           Shelly
+import           Shelly.Lifted            (liftSh)
 import           VeriFuzz.Sim.Internal
 import           VeriFuzz.Sim.Template
 import           VeriFuzz.Verilog.AST
@@ -35,16 +36,18 @@ instance Synthesiser Vivado where
 defaultVivado :: Vivado
 defaultVivado = Vivado "vivado"
 
-runSynthVivado :: Vivado -> SourceInfo -> FilePath -> Sh ()
+runSynthVivado :: Vivado -> SourceInfo -> FilePath -> ResultSh ()
 runSynthVivado sim (SourceInfo top src) outf = do
-    dir <- pwd
-    writefile vivadoTcl . vivadoSynthConfig top $ toTextIgnore outf
-    writefile "rtl.v" $ genSource src
-    run_ "sed" ["s/^module/(* use_dsp48=\"no\" *) module/;", "-i", "rtl.v"]
-    echoP "Vivado: run"
-    logger_ dir "vivado"
-        $ timeout
-              (vivadoPath sim)
-              ["-mode", "batch", "-source", toTextIgnore vivadoTcl]
-    echoP "Vivado: done"
+    dir <- liftSh pwd
+    liftSh $ do
+        writefile vivadoTcl . vivadoSynthConfig top $ toTextIgnore outf
+        writefile "rtl.v" $ genSource src
+        run_ "sed" ["s/^module/(* use_dsp48=\"no\" *) module/;", "-i", "rtl.v"]
+        echoP "Vivado: run"
+    execute_ SynthFail
+             dir
+             "vivado"
+             (vivadoPath sim)
+             ["-mode", "batch", "-source", toTextIgnore vivadoTcl]
+    liftSh $ echoP "Vivado: done"
     where vivadoTcl = fromText ("vivado_" <> top) <.> "tcl"
diff --git a/src/VeriFuzz/Sim/XST.hs b/src/VeriFuzz/Sim/XST.hs
index 40bd637..866563c 100644
--- a/src/VeriFuzz/Sim/XST.hs
+++ b/src/VeriFuzz/Sim/XST.hs
@@ -20,6 +20,7 @@ where
 
 import           Prelude                  hiding (FilePath)
 import           Shelly
+import           Shelly.Lifted            (liftSh)
 import           Text.Shakespeare.Text    (st)
 import           VeriFuzz.Sim.Internal
 import           VeriFuzz.Sim.Template
@@ -40,16 +41,18 @@ instance Synthesiser XST where
 defaultXST :: XST
 defaultXST = XST "xst" "netgen"
 
-runSynthXST :: XST -> SourceInfo -> FilePath -> Sh ()
+runSynthXST :: XST -> SourceInfo -> FilePath -> ResultSh ()
 runSynthXST sim (SourceInfo top src) outf = do
-    dir <- pwd
-    writefile xstFile $ xstSynthConfig top
-    writefile prjFile [st|verilog work "rtl.v"|]
-    writefile "rtl.v" $ genSource src
-    echoP "XST: run"
-    logger_ dir "xst" $ timeout (xstPath sim) ["-ifn", toTextIgnore xstFile]
-    echoP "XST: netgen"
-    logger_ dir "netgen" $ run
+    dir <- liftSh pwd
+    let exec = execute_ SynthFail dir "xst"
+    liftSh $ do
+        writefile xstFile $ xstSynthConfig top
+        writefile prjFile [st|verilog work "rtl.v"|]
+        writefile "rtl.v" $ genSource src
+        echoP "XST: run"
+    exec (xstPath sim) ["-ifn", toTextIgnore xstFile]
+    liftSh $ echoP "XST: netgen"
+    exec
         (netgenPath sim)
         [ "-w"
         , "-ofmt"
@@ -57,14 +60,15 @@ runSynthXST sim (SourceInfo top src) outf = do
         , toTextIgnore $ modFile <.> "ngc"
         , toTextIgnore outf
         ]
-    echoP "XST: clean"
-    noPrint $ run_
-        "sed"
-        [ "-i"
-        , "/^`ifndef/,/^`endif/ d; s/ *Timestamp: .*//;"
-        , toTextIgnore outf
-        ]
-    echoP "XST: done"
+    liftSh $ do
+        echoP "XST: clean"
+        noPrint $ run_
+            "sed"
+            [ "-i"
+            , "/^`ifndef/,/^`endif/ d; s/ *Timestamp: .*//;"
+            , toTextIgnore outf
+            ]
+        echoP "XST: done"
   where
     modFile = fromText $ "xst_" <> top
     xstFile = modFile <.> "xst"