WIP: more refactoring

src/Swarm/App.hs

@@ -8,15 +8,17 @@ module Swarm.App where
 
 import Brick
 import Brick.BChan
+import Control.Carrier.Lift (runM)
+import Control.Carrier.Throw.Either (runThrow)
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Lens (view, (%~), (&), (?~))
 import Control.Monad (forever, void, when)
-import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Class (liftIO)
 import Data.IORef (newIORef, writeIORef)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Graphics.Vty qualified as V
+import Swarm.Game.Failure.Render (prettyFailure)
 import Swarm.Game.Robot (ErrorLevel (..), LogSource (ErrorTrace, Said))
 import Swarm.ReadableIORef (mkReadonly)
 import Swarm.TUI.Controller
@@ -45,9 +47,9 @@ app eventHandler =
 --   some communication channels, and runs the UI.
 appMain :: AppOpts -> IO ()
 appMain opts = do
-  res <- runExceptT $ initAppState opts
+  res <- runM . runThrow $ initAppState opts
   case res of
-    Left errMsg -> T.hPutStrLn stderr errMsg
+    Left err -> T.hPutStrLn stderr (prettyFailure err)
     Right s -> do
       -- Send Frame events as at a reasonable rate for 30 fps. The
       -- game is responsible for figuring out how many steps to take
@@ -112,9 +114,9 @@ demoWeb :: IO ()
 demoWeb = do
   let demoPort = 8080
   res <-
-    runExceptT $ initAppState (defaultAppOpts {userScenario = demoScenario})
+    runM . runThrow $ initAppState (defaultAppOpts {userScenario = demoScenario})
   case res of
-    Left errMsg -> T.putStrLn errMsg
+    Left err -> T.putStrLn (prettyFailure err)
     Right s -> do
       appStateRef <- newIORef s
       chan <- newBChan 5

src/Swarm/Doc/Gen.hs

@@ -62,8 +62,8 @@ import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax (Const (..))
 import Swarm.Language.Syntax qualified as Syntax
 import Swarm.Language.Typecheck (inferConst)
-import Swarm.Util (both, guardRight, listEnums, quote, simpleErrorHandle)
-import Swarm.Util.Effect (throwToMaybe)
+import Swarm.Util (both, guardRight, listEnums, quote)
+import Swarm.Util.Effect (simpleErrorHandle, throwToMaybe)
 import Text.Dot (Dot, NodeId, (.->.))
 import Text.Dot qualified as Dot
 import Witch (from)

src/Swarm/Doc/Pedagogy.hs

@@ -18,11 +18,8 @@ module Swarm.Doc.Pedagogy (
 
 import Control.Arrow ((&&&))
 import Control.Carrier.Accum.Strict (evalAccum)
-import Control.Carrier.Lift (runM)
 import Control.Lens (universe, view)
 import Control.Monad (guard, (<=<))
-import Control.Monad.Except (ExceptT (..))
-import Control.Monad.Trans.Class (lift)
 import Data.List (foldl', intercalate, sort, sortOn)
 import Data.List.Extra (zipFrom)
 import Data.Map (Map)
@@ -44,7 +41,7 @@ import Swarm.Language.Pipeline (ProcessedTerm (..))
 import Swarm.Language.Syntax
 import Swarm.Language.Types (Polytype)
 import Swarm.TUI.Controller (getTutorials)
-import Swarm.Util (simpleErrorHandle)
+import Swarm.Util.Effect (simpleErrorHandle)
 
 -- * Constants
 
@@ -160,8 +157,8 @@ generateIntroductionsSequence =
 -- For unit tests, can instead access the scenarios via the GameState.
 loadScenarioCollection :: IO ScenarioCollection
 loadScenarioCollection = simpleErrorHandle $ do
-  entities <- ExceptT loadEntities
-  lift . runM . evalAccum (mempty :: Seq SystemFailure) $ loadScenarios entities
+  entities <- loadEntities
+  evalAccum (mempty :: Seq SystemFailure) $ loadScenarios entities -- ignore warnings
 
 renderUsagesMarkdown :: CoverageInfo -> Text
 renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) =

src/Swarm/Game/Failure.hs

@@ -12,6 +12,8 @@ import Data.Yaml (ParseException)
 
 data SystemFailure
   = AssetNotLoaded Asset FilePath LoadingFailure
+  | ScenarioNotFound FilePath
+  | CustomFailure Text
 
 data AssetData = AppAsset | NameGeneration | Entities | Recipes | Scenarios | Script
   deriving (Eq, Show)

src/Swarm/Game/Failure/Render.hs

@@ -12,6 +12,7 @@ import Data.Text qualified as T
 import Data.Yaml (prettyPrintParseException)
 import Swarm.Game.Failure
 import Swarm.Util (quote)
+import Witch (into)
 
 tShowLow :: Show a => a -> Text
 tShowLow = T.pack . map toLower . show
@@ -33,3 +34,6 @@ prettyFailure :: SystemFailure -> Text
 prettyFailure = \case
   AssetNotLoaded a fp l ->
     T.unwords ["Failed to acquire", tShowLow a, tShow fp, "from path", quote $ T.pack fp] <> ": " <> prettyLoadingFailure l
+  ScenarioNotFound s ->
+    "Scenario not found: " <> into @Text s
+  CustomFailure m -> m

src/Swarm/Game/Scenario.hs

@@ -46,15 +46,13 @@ module Swarm.Game.Scenario (
   getScenarioPath,
 ) where
 
-import Control.Algebra (Has, run)
 import Control.Arrow ((&&&))
 import Control.Carrier.Throw.Either (runThrow)
 import Control.Effect.Lift (Lift, sendIO)
-import Control.Effect.Throw (Throw, liftEither)
+import Control.Effect.Throw
 import Control.Lens hiding (from, (.=), (<.>))
 import Control.Monad (filterM, unless, (<=<))
 import Data.Aeson
-import Data.Either.Extra (maybeToEither)
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
@@ -84,7 +82,6 @@ import Swarm.Util.Lens (makeLensesNoSigs)
 import Swarm.Util.Yaml
 import System.Directory (doesFileExist)
 import System.FilePath ((<.>), (</>))
-import Witch (into)
 
 ------------------------------------------------------------
 -- Scenario
@@ -262,14 +259,13 @@ getScenarioPath scenario = do
 --   requested on the command line.
 loadScenario ::
   (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
-  String ->
+  FilePath ->
   EntityMap ->
   m (Scenario, FilePath)
 loadScenario scenario em = do
   mfileName <- getScenarioPath scenario
-  fileName <- liftEither $ maybeToEither ("Scenario not found: " <> into @Text scenario) mfileName
-  s <- withThrow prettyFailure $ loadScenarioFile em fileName
-  return (s, fileName)
+  fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName
+  (,fileName) <$> loadScenarioFile em fileName
 
 -- | Load a scenario from a file.
 loadScenarioFile ::

src/Swarm/Game/State.hs

@@ -94,7 +94,6 @@ module Swarm.Game.State (
   Sha1 (..),
   SolutionSource (..),
   parseCodeFile,
-  getParsedInitialCode,
 
   -- * Utilities
   applyViewCenterRule,
@@ -123,14 +122,14 @@ module Swarm.Game.State (
   getRunCodePath,
 ) where
 
-import Control.Algebra (Has)
 import Control.Applicative ((<|>))
-import Control.Arrow (Arrow ((&&&)), left)
+import Control.Arrow (Arrow ((&&&)))
 import Control.Effect.Lens
+import Control.Effect.Lift
 import Control.Effect.State (State)
+import Control.Effect.Throw
 import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
 import Control.Monad (forM_)
-import Control.Monad.Except (ExceptT (..))
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Array (Array, listArray)
 import Data.Bifunctor (first)
@@ -151,7 +150,7 @@ import Data.Sequence (Seq ((:<|)))
 import Data.Sequence qualified as Seq
 import Data.Set qualified as S
 import Data.Text (Text)
-import Data.Text qualified as T (drop, pack, take)
+import Data.Text qualified as T (drop, take)
 import Data.Text.IO qualified as TIO
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TL
@@ -163,6 +162,7 @@ import Swarm.Game.Achievement.Attainment
 import Swarm.Game.Achievement.Definitions
 import Swarm.Game.CESK (CESK (Waiting), TickNumber (..), addTicks, emptyStore, finalValue, initMachine)
 import Swarm.Game.Entity
+import Swarm.Game.Failure (SystemFailure (..))
 import Swarm.Game.Location
 import Swarm.Game.Recipe (
   Recipe,
@@ -299,24 +299,23 @@ getRunCodePath (CodeToRun solutionSource _) = case solutionSource of
   ScenarioSuggested -> Nothing
   PlayerAuthored fp _ -> Just fp
 
-parseCodeFile :: FilePath -> IO (Either Text CodeToRun)
+parseCodeFile ::
+  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
+  FilePath ->
+  m CodeToRun
 parseCodeFile filepath = do
-  contents <- TIO.readFile filepath
-  return $ do
-    pt@(ProcessedTerm (Module (Syntax' srcLoc _ _) _) _ _) <-
-      left T.pack $ processTermEither contents
-    let strippedText = stripSrc srcLoc contents
-        programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText
-        sha1Hash = showDigest $ sha1 programBytestring
-    return $ CodeToRun (PlayerAuthored filepath $ Sha1 sha1Hash) pt
+  contents <- sendIO $ TIO.readFile filepath
+  pt@(ProcessedTerm (Module (Syntax' srcLoc _ _) _) _ _) <-
+    either (throwError . CustomFailure) return (processTermEither contents)
+  let strippedText = stripSrc srcLoc contents
+      programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText
+      sha1Hash = showDigest $ sha1 programBytestring
+  return $ CodeToRun (PlayerAuthored filepath $ Sha1 sha1Hash) pt
  where
   stripSrc :: SrcLoc -> Text -> Text
   stripSrc (SrcLoc start end) txt = T.drop start $ T.take end txt
   stripSrc NoLoc txt = txt
 
-getParsedInitialCode :: Maybe FilePath -> ExceptT Text IO (Maybe CodeToRun)
-getParsedInitialCode = traverse $ ExceptT . parseCodeFile
-
 ------------------------------------------------------------
 -- The main GameState record type
 ------------------------------------------------------------

src/Swarm/Language/Pipeline.hs

@@ -32,7 +32,7 @@ import Swarm.Language.Requirement
 import Swarm.Language.Syntax
 import Swarm.Language.Typecheck
 import Swarm.Language.Types
-import Witch
+import Witch (into)
 
 -- | A record containing the results of the language processing
 --   pipeline.  Put a 'Term' in, and get one of these out.  A
@@ -48,14 +48,14 @@ import Witch
 data ProcessedTerm = ProcessedTerm TModule Requirements ReqCtx
   deriving (Data, Show, Eq, Generic)
 
-processTermEither :: Text -> Either String ProcessedTerm
+processTermEither :: Text -> Either Text ProcessedTerm
 processTermEither t = case processTerm t of
-  Left err -> Left $ "Could not parse term: " ++ from err
+  Left err -> Left $ "Could not parse term: " <> err
   Right Nothing -> Left "Term was only whitespace"
   Right (Just pt) -> Right pt
 
 instance FromJSON ProcessedTerm where
-  parseJSON = withText "Term" $ either fail return . processTermEither
+  parseJSON = withText "Term" $ either (fail . into @String) return . processTermEither
 
 instance ToJSON ProcessedTerm where
   toJSON (ProcessedTerm t _ _) = String $ prettyText (moduleAST t)

src/Swarm/TUI/Launch/Model.hs

@@ -11,12 +11,15 @@ module Swarm.TUI.Launch.Model where
 import Brick.Focus qualified as Focus
 import Brick.Widgets.Edit
 import Brick.Widgets.FileBrowser qualified as FB
+import Control.Carrier.Throw.Either (runThrow)
 import Control.Lens (makeLenses)
 import Data.Functor.Identity (Identity (Identity))
 import Data.Text (Text)
+import Swarm.Game.Failure.Render (prettyFailure)
 import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (LaunchParams), ScenarioInfoPair, SerializableLaunchParams)
-import Swarm.Game.State (CodeToRun, LaunchParams, ValidatedLaunchParams, getRunCodePath, parseCodeFile)
+import Swarm.Game.State (LaunchParams, ValidatedLaunchParams, getRunCodePath, parseCodeFile)
 import Swarm.TUI.Model.Name
+import Swarm.Util.Effect (withThrow)
 
 -- | Use this to store error messages
 -- on individual fields
@@ -26,16 +29,9 @@ toSerializableParams :: ValidatedLaunchParams -> SerializableLaunchParams
 toSerializableParams (LaunchParams seedValue (Identity codeToRun)) =
   LaunchParams seedValue $ pure $ getRunCodePath =<< codeToRun
 
-parseCode :: Maybe FilePath -> IO (Either Text (Maybe CodeToRun))
-parseCode maybeSelectedFile = case maybeSelectedFile of
-  Just codeFile -> do
-    eitherParsedCode <- parseCodeFile codeFile
-    return $ Just <$> eitherParsedCode
-  Nothing -> return $ Right Nothing
-
 fromSerializableParams :: SerializableLaunchParams -> IO EditingLaunchParams
 fromSerializableParams (LaunchParams (Identity maybeSeedValue) (Identity maybeCodePath)) = do
-  eitherCode <- parseCode maybeCodePath
+  eitherCode <- runThrow . withThrow prettyFailure $ traverse parseCodeFile maybeCodePath
   return $ LaunchParams (Right maybeSeedValue) eitherCode
 
 data FileBrowserControl = FileBrowserControl

src/Swarm/TUI/Launch/Prep.hs

@@ -13,15 +13,18 @@ import Brick.Focus qualified as Focus
 import Brick.Widgets.Edit
 import Brick.Widgets.FileBrowser qualified as FB
 import Control.Arrow (left)
+import Control.Carrier.Throw.Either (runThrow)
 import Control.Lens ((.=), (^.))
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Functor.Identity (runIdentity)
 import Data.Text qualified as T
+import Swarm.Game.Failure.Render (prettyFailure)
 import Swarm.Game.Scenario.Status (ParameterizableLaunchParams (..), ScenarioInfoPair, getLaunchParams, scenarioStatus)
-import Swarm.Game.State (Seed, ValidatedLaunchParams, getRunCodePath)
+import Swarm.Game.State (Seed, ValidatedLaunchParams, getRunCodePath, parseCodeFile)
 import Swarm.TUI.Launch.Model
 import Swarm.TUI.Model.Name
 import Swarm.Util (listEnums)
+import Swarm.Util.Effect (withThrow)
 import System.FilePath (takeDirectory)
 import Text.Read (readEither)
 
@@ -49,7 +52,7 @@ parseSeedInput seedEditor =
 
 parseWidgetParams :: LaunchControls -> IO EditingLaunchParams
 parseWidgetParams (LaunchControls (FileBrowserControl _fb maybeSelectedScript _) seedEditor _ _) = do
-  eitherParsedCode <- parseCode maybeSelectedScript
+  eitherParsedCode <- runThrow . withThrow prettyFailure $ traverse parseCodeFile maybeSelectedScript
   return $ LaunchParams eitherMaybeSeed eitherParsedCode
  where
   eitherMaybeSeed = parseSeedInput seedEditor

src/Swarm/TUI/Model/StateUpdate.hs

@@ -27,7 +27,7 @@ import Control.Effect.Lift
 import Control.Effect.Throw
 import Control.Lens hiding (from, (<.>))
 import Control.Monad (guard, void)
-import Control.Monad.Except (ExceptT)
+import Control.Monad.Except (ExceptT (..))
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.State (MonadState, execStateT)
 import Data.Foldable qualified as F
@@ -67,7 +67,7 @@ import Swarm.TUI.Model.Goal (emptyGoalDisplay)
 import Swarm.TUI.Model.Repl
 import Swarm.TUI.Model.UI
 import Swarm.TUI.View.CustomStyling (toAttrPair)
-import Swarm.Util.Effect (withThrow)
+import Swarm.Util.Effect (asExceptT, withThrow)
 import System.Clock
 
 -- | Initialize the 'AppState' from scratch.
@@ -123,21 +123,22 @@ constructAppState rs ui opts@(AppOpts {..}) = do
     False -> return $ AppState gs (ui & lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs
     True -> do
       (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap)
-      maybeRunScript <- getParsedInitialCode scriptToRun
+      maybeRunScript <- traverse parseCodeFile scriptToRun
 
       let maybeAutoplay = do
             guard autoPlay
             soln <- scenario ^. scenarioSolution
             return $ CodeToRun ScenarioSuggested soln
           codeToRun = maybeAutoplay <|> maybeRunScript
 
-      eitherSi <- liftIO . runM . runThrow $ loadScenarioInfo path
+      eitherSi <- sendIO . runM . runThrow $ loadScenarioInfo path
       let (si, newRs) = case eitherSi of
             Right x -> (x, rs)
             Left e -> (ScenarioInfo path NotStarted, addWarnings rs [e])
-      execStateT
-        (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun))
-        (AppState gs ui newRs)
+      sendIO $
+        execStateT
+          (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun))
+          (AppState gs ui newRs)
 
 -- | Load a 'Scenario' and start playing the game.
 startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m ()
@@ -271,7 +272,7 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do
 --   to update it using 'scenarioToAppState'.
 initAppStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState
 initAppStateForScenario sceneName userSeed toRun =
-  initAppState (defaultAppOpts {userScenario = Just sceneName, userSeed = userSeed, scriptToRun = toRun})
+  asExceptT . withThrow prettyFailure $ initAppState (defaultAppOpts {userScenario = Just sceneName, userSeed = userSeed, scriptToRun = toRun})
 
 -- | For convenience, the 'AppState' corresponding to the classic game
 --   with seed 0.  This is used only for benchmarks and unit tests.

src/Swarm/TUI/View.hs

@@ -130,7 +130,7 @@ drawUI s
       NewGameMenu stk -> drawNewGameMenuUI stk $ s ^. uiState . uiLaunchConfig
       AchievementsMenu l -> [drawAchievementsMenuUI s l]
       MessagesMenu -> [drawMainMessages s]
-      AboutMenu -> [drawAboutMenuUI (s ^. uiState . appData . at "about")]
+      AboutMenu -> [drawAboutMenuUI (s ^. runtimeState . appData . at "about")]
 
 drawMainMessages :: AppState -> Widget Name
 drawMainMessages s = renderDialog dial . padBottom Max . scrollList $ drawLogs ls
@@ -149,7 +149,7 @@ drawMainMenuUI s l =
         BL.renderList (const (hCenter . drawMainMenuEntry s)) True l
     ]
  where
-  logo = s ^. uiState . appData . at "logo"
+  logo = s ^. runtimeState . appData . at "logo"
   version = s ^. runtimeState . upstreamRelease
 
 newVersionWidget :: Either NewReleaseFailure String -> Maybe (Widget n)