Refactor Echidna.UI to improve readability (#829)

crytic · Nov 10, 2022 · d33bb31 · d33bb31
1 parent 7e64a58
commit d33bb31
Showing 1 changed file with 37 additions and 35 deletions.
diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs
@@ -52,58 +52,36 @@ makeLenses ''UIConf
 
 data CampaignEvent = CampaignUpdated Campaign | CampaignTimedout Campaign
 
-vtyConfig :: Config
-vtyConfig = defaultConfig { inputMap = (Nothing, "\ESC[6;2~", EvKey KPageDown [MShift]) :
-                                       (Nothing, "\ESC[5;2~", EvKey KPageUp [MShift]) :
-                                       inputMap defaultConfig
-                          }
-
--- | Check if we should stop drawing (or updating) the dashboard, then do the right thing.
-monitor :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
-        => m (App (Campaign, UIState) CampaignEvent ())
-monitor = do
-  let cs :: (CampaignConf, Names, TxConf) -> (Campaign, UIState) -> Widget ()
-      cs s c = runReader (campaignStatus c) s
-
-      se _ (AppEvent (CampaignUpdated c')) = continue (c', Running)
-      se _ (AppEvent (CampaignTimedout c')) = continue (c', Timedout)
-      se c (VtyEvent (EvKey KEsc _))                         = halt c
-      se c (VtyEvent (EvKey (KChar 'c') l)) | MCtrl `elem` l = halt c
-      se c _                                                 = continue c
-  s <- (,,) <$> view hasLens <*> view hasLens <*> view hasLens
-  pure $ App (pure . cs s) neverShowCursor se pure (const attrs)
-
--- | Heuristic check that we're in a sensible terminal (not a pipe)
-isTerminal :: MonadIO m => m Bool
-isTerminal = liftIO $ (&&) <$> queryTerminal (Fd 0) <*> queryTerminal (Fd 1)
-
 -- | Set up and run an Echidna 'Campaign' and display interactive UI or
 -- print non-interactive output in desired format at the end
 ui :: ( MonadCatch m, MonadRandom m, MonadReader x m, MonadUnliftIO m
-      , Has SolConf x, Has TestConf x, Has TxConf x, Has CampaignConf x, Has Names x, Has TxConf x, Has UIConf x, Has DappInfo x)
+      , Has SolConf x, Has TestConf x, Has TxConf x, Has CampaignConf x
+      , Has Names x, Has TxConf x, Has UIConf x, Has DappInfo x)
    => VM             -- ^ Initial VM state
    -> World          -- ^ Initial world state
-   -> [EchidnaTest]      -- ^ Tests to evaluate
+   -> [EchidnaTest]  -- ^ Tests to evaluate
    -> Maybe GenDict
    -> [[Tx]]
    -> m Campaign
-ui v w ts d txs = do
+ui vm world ts d txs = do
+  campaignConf <- view hasLens
   ref <- liftIO $ newIORef defaultCampaign
   let updateRef = use hasLens >>= liftIO . atomicWriteIORef ref
       secToUsec = (* 1000000)
-  timeoutUsec <- secToUsec . fromMaybe (-1) <$> view (hasLens . maxTime)
+      timeoutUsec = secToUsec $ fromMaybe (-1) (campaignConf ^. maxTime)
+      runCampaign = timeout timeoutUsec (campaign updateRef vm world ts d txs)
   terminalPresent <- isTerminal
-  effectiveMode <- view (hasLens . operationMode) <&> \case
-    Interactive | not terminalPresent -> NonInteractive Text
-    other -> other
+  let effectiveMode = case campaignConf ^. operationMode of
+        Interactive | not terminalPresent -> NonInteractive Text
+        other -> other
   case effectiveMode of
     Interactive -> do
       bc <- liftIO $ newBChan 100
       let updateUI e = readIORef ref >>= writeBChan bc . e
       ticker <- liftIO $ forkIO $ -- run UI update every 100ms
         forever $ threadDelay 100000 >> updateUI CampaignUpdated
       _ <- forkFinally -- run worker
-        (void $ timeout timeoutUsec (campaign updateRef v w ts d txs) >>= \case
+        (void $ runCampaign >>= \case
           Nothing -> liftIO $ updateUI CampaignTimedout
           Just _ -> liftIO $ updateUI CampaignUpdated
         )
@@ -117,7 +95,7 @@ ui v w ts d txs = do
       pure final
 
     NonInteractive outputFormat -> do
-      result <- timeout timeoutUsec (campaign updateRef v w ts d txs)
+      result <- runCampaign
       (final, timedout) <- case result of
         Nothing -> do
           final <- liftIO $ readIORef ref
@@ -132,5 +110,29 @@ ui v w ts d txs = do
           when timedout $ liftIO $ putStrLn "TIMEOUT!"
         None ->
           pure ()
-
       pure final
+
+vtyConfig :: Config
+vtyConfig = defaultConfig { inputMap = (Nothing, "\ESC[6;2~", EvKey KPageDown [MShift]) :
+                                       (Nothing, "\ESC[5;2~", EvKey KPageUp [MShift]) :
+                                       inputMap defaultConfig
+                          }
+
+-- | Check if we should stop drawing (or updating) the dashboard, then do the right thing.
+monitor :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
+        => m (App (Campaign, UIState) CampaignEvent ())
+monitor = do
+  let cs :: (CampaignConf, Names, TxConf) -> (Campaign, UIState) -> Widget ()
+      cs s c = runReader (campaignStatus c) s
+
+      se _ (AppEvent (CampaignUpdated c')) = continue (c', Running)
+      se _ (AppEvent (CampaignTimedout c')) = continue (c', Timedout)
+      se c (VtyEvent (EvKey KEsc _))                         = halt c
+      se c (VtyEvent (EvKey (KChar 'c') l)) | MCtrl `elem` l = halt c
+      se c _                                                 = continue c
+  s <- (,,) <$> view hasLens <*> view hasLens <*> view hasLens
+  pure $ App (pure . cs s) neverShowCursor se pure (const attrs)
+
+-- | Heuristic check that we're in a sensible terminal (not a pipe)
+isTerminal :: MonadIO m => m Bool
+isTerminal = liftIO $ (&&) <$> queryTerminal (Fd 0) <*> queryTerminal (Fd 1)