Move parse + typecheck failures from LoadingFailure to SystemFailure

src/swarm-scenario/Swarm/Game/Entity.hs

@@ -490,7 +490,8 @@ validateEntityAttrRefs validAttrs es =
       AWorld n ->
         unless (Set.member (WorldAttr $ T.unpack n) validAttrs)
           . throwError
-          . CustomMessage
+          . SystemFailure
+          . CustomFailure
           $ T.unwords
             [ "Nonexistent attribute"
             , quote n
@@ -509,7 +510,7 @@ buildEntityMap es = do
   forM_ (findDup $ map fst namedEntities) $
     throwError . Duplicate Entities
   case combineEntityCapsM entsByName es of
-    Left x -> throwError $ CustomMessage x
+    Left x -> throwError . SystemFailure . CustomFailure $ x
     Right ebc ->
       return $
         EntityMap

src/swarm-scenario/Swarm/Game/Recipe.hs

@@ -163,7 +163,7 @@ loadRecipes em = do
     withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParseYaml)
       . (liftEither <=< sendIO)
       $ decodeFileEither @[Recipe Text] fileName
-  withThrow (AssetNotLoaded (Data Recipes) fileName . CustomMessage)
+  withThrow (AssetNotLoaded (Data Recipes) fileName . SystemFailure . CustomFailure)
     . liftEither
     . left (T.append "Unknown entities in recipe(s): " . T.intercalate ", ")
     . validationToEither

src/swarm-scenario/Swarm/Game/Terrain.hs

@@ -134,7 +134,8 @@ validateTerrainAttrRefs validAttrs rawTerrains =
   forM rawTerrains $ \(TerrainItem n a d) -> do
     unless (Set.member (WorldAttr $ T.unpack a) validAttrs)
       . throwError
-      . CustomMessage
+      . SystemFailure
+      . CustomFailure
       $ T.unwords
         [ "Nonexistent attribute"
         , quote a

src/swarm-scenario/Swarm/Game/World/Load.hs

@@ -46,10 +46,10 @@ loadWorld ::
   m (Text, Some (TTerm '[]))
 loadWorld dir tem (fp, src) = do
   wexp <-
-    liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $
+    liftEither . left (AssetNotLoaded (Data Worlds) fp . SystemFailure . CanNotParseMegaparsec) $
       runParser parseWExp (into @Text src)
   t <-
-    withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $
+    withThrow (AssetNotLoaded (Data Worlds) fp . SystemFailure . DoesNotTypecheck . prettyText @CheckErr) $
       runReader tem . runReader @WorldMap M.empty $
         infer CNil wexp
   return (into @Text (dropExtension (stripDir dir fp)), t)

src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs

@@ -41,7 +41,7 @@ loadKeybindingConfig = do
     else do
       loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini
       case loadedCustomBindings of
-        Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e)
+        Left e -> throwError $ AssetNotLoaded Keybindings ini (SystemFailure . CustomFailure $ T.pack e)
         Right bs -> pure $ fromMaybe [] bs
 
 initKeyHandlingState ::

src/swarm-util/Swarm/Failure.hs

@@ -52,10 +52,8 @@ data LoadingFailure
   = DoesNotExist Entry
   | EntryNot Entry
   | CanNotParseYaml ParseException
-  | CanNotParseMegaparsec (ParseErrorBundle Text Void)
-  | DoesNotTypecheck Text -- See Note [Typechecking errors]
   | Duplicate AssetData Text
-  | CustomMessage Text
+  | SystemFailure SystemFailure
   deriving (Show)
 
 -- ~~~~ Note [Pretty-printing typechecking errors]
@@ -79,6 +77,8 @@ data SystemFailure
   = AssetNotLoaded Asset FilePath LoadingFailure
   | ScenarioNotFound FilePath
   | OrderFileWarning FilePath OrderFileWarning
+  | CanNotParseMegaparsec (ParseErrorBundle Text Void)
+  | DoesNotTypecheck Text -- See Note [Typechecking errors]
   | CustomFailure Text
   deriving (Show)
 
@@ -106,23 +106,15 @@ instance PrettyPrec Entry where
   prettyPrec _ = prettyShowLow
 
 instance PrettyPrec LoadingFailure where
-  prettyPrec _ = \case
+  prettyPrec prec = \case
     DoesNotExist e -> "The" <+> ppr e <+> "is missing!"
     EntryNot e -> "The entry is not a" <+> ppr e <> "!"
     CanNotParseYaml p ->
       nest 2 . vcat $
         "Parse failure:"
           : map pretty (T.lines (into @Text (prettyPrintParseException p)))
-    CanNotParseMegaparsec p ->
-      nest 2 . vcat $
-        "Parse failure:"
-          : map pretty (T.lines (into @Text (errorBundlePretty p)))
-    DoesNotTypecheck t ->
-      nest 2 . vcat $
-        "Parse failure:"
-          : map pretty (T.lines t)
     Duplicate thing duped -> "Duplicate" <+> ppr thing <> ":" <+> squotes (pretty duped)
-    CustomMessage m -> pretty m
+    SystemFailure g -> prettyPrec prec g
 
 instance PrettyPrec OrderFileWarning where
   prettyPrec _ = \case
@@ -147,4 +139,12 @@ instance PrettyPrec SystemFailure where
         [ "Warning: while processing" <+> pretty orderFile <> ":"
         , ppr w
         ]
+    CanNotParseMegaparsec p ->
+      nest 2 . vcat $
+        "Parse failure:"
+          : map pretty (T.lines (into @Text (errorBundlePretty p)))
+    DoesNotTypecheck t ->
+      nest 2 . vcat $
+        "Parse failure:"
+          : map pretty (T.lines t)
     CustomFailure m -> pretty m

src/swarm-util/Swarm/ResourceLoading.hs

@@ -146,7 +146,7 @@ readAppData = do
   dirMembers :: [FilePath] <-
     (liftEither <=< sendIO) $
       (pure <$> listDirectory d) `catch` \(e :: IOException) ->
-        return . Left . AssetNotLoaded (Data AppAsset) d . CustomMessage . T.pack $ show e
+        return . Left . AssetNotLoaded (Data AppAsset) d . SystemFailure . CustomFailure . T.pack $ show e
   let fs = filter ((== ".txt") . takeExtension) dirMembers
 
   filesList <- sendIO $ forM fs (\f -> (into @Text (dropExtension f),) <$> readFileMayT (d </> f))